From b2fbd8137d565861064dae1357605691beb7549d Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Fri, 25 Nov 2022 21:12:04 -0600 Subject: [PATCH 01/36] replace by inherits --- DESCRIPTION | 1 - R/create_depths_profile.R | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 42fcd30..a56b02c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -8,7 +8,6 @@ Description: Analysis of molecular marker data from model (backcrosses, phases (genetic map construction) according to Wu et al. (2002) . All analysis are based on multipoint approaches using hidden Markov models. -Date: 2022-02-10 Authors@R: c(person("Gabriel", "Margarido", role = "aut", diff --git a/R/create_depths_profile.R b/R/create_depths_profile.R index ea55d20..192c456 100644 --- a/R/create_depths_profile.R +++ b/R/create_depths_profile.R @@ -237,11 +237,11 @@ create_depths_profile <- function(onemap.obj = NULL, if(length(rm.mks) > 0) data <- data[-rm.mks,] - if(class(mks) == "character"){ + if(inherits(mks,"character")){ data <- data[which(data$mks %in% mks),] } - if(class(inds) == "character"){ + if(inherits(inds, "character")){ data <- data[which(data$ind %in% inds),] } From 4539d42e96d81a36256d496742a15652b67e9404 Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Tue, 29 Nov 2022 11:46:00 -0600 Subject: [PATCH 02/36] remove ind update --- R/utils.R | 72 ++++++++++++++++++++----------------- man/remove_inds.Rd | 25 ++++--------- tests/testthat/test-utils.R | 18 +++++++--- 3 files changed, 58 insertions(+), 57 deletions(-) diff --git a/R/utils.R b/R/utils.R index 23fee30..f1d03f8 100644 --- a/R/utils.R +++ b/R/utils.R @@ -112,45 +112,51 @@ split_2pts <- function(twopts.obj, mks){ } -#'Remove individuals from the onemap object +#' Remove individuals from the onemap object #' -#'@param onemap.obj object of class onemap -#'@param rm.ind vector of characters with individuals names +#' @param onemap.obj object of class onemap +#' @param rm.ind vector of characters with individuals names +#' @param list.seqs list of objects of class sequence #' -##' @return An object of class \code{onemap} without the selected individuals, -##' i.e., a list with the following -##' components: \item{geno}{a matrix with integers indicating the genotypes -##' read for each marker. Each column contains data for a marker and each row -##' represents an individual.} \item{n.ind}{number of individuals.} -##' \item{n.mar}{number of markers.} \item{segr.type}{a vector with the -##' segregation type of each marker, as \code{strings}.} \item{segr.type.num}{a -##' vector with the segregation type of each marker, represented in a -##' simplified manner as integers, i.e. 1 corresponds to markers of type -##' \code{"A"}; 2 corresponds to markers of type \code{"B1.5"}; 3 corresponds -##' to markers of type \code{"B2.6"}; 4 corresponds to markers of type -##' \code{"B3.7"}; 5 corresponds to markers of type \code{"C.8"}; 6 corresponds -##' to markers of type \code{"D1"} and 7 corresponds to markers of type -##' \code{"D2"}. Markers for F2 intercrosses are coded as 1; all other crosses -##' are left as \code{NA}.} \item{input}{the name of the input file.} -##' \item{n.phe}{number of phenotypes.} \item{pheno}{a matrix with phenotypic -##' values. Each column contains data for a trait and each row represents an -##' individual.} +#' @return An object of class \code{onemap} without the selected individuals +#' if onemap object is used as input, or a list of objects of class \code{sequence} +#' without the selected individuals if a list of sequences objects is use as input #' -##' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} +#' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} #' #'@export -remove_inds <- function(onemap.obj, rm.ind){ - if(!inherits(onemap.obj, "onemap")) stop("Input must to be of onemap class \n") - if(!(length(which(rownames(onemap.obj$geno) %in% rm.ind)) >0)) stop("We could not find any of these individuals in the dataset \n") - - new.onemap.obj <- onemap.obj - new.onemap.obj$geno <- onemap.obj$geno[-which(rownames(onemap.obj$geno) %in% rm.ind),] - new.onemap.obj$n.ind <- onemap.obj$n.ind - length(rm.ind) - for(i in 1:length(rm.ind)){ - rm.idx <- grep(paste0("_",rm.ind[i],"$"), rownames(new.onemap.obj$error)) - new.onemap.obj$error <- new.onemap.obj$error[-rm.idx,] +remove_inds <- function(onemap.obj=NULL, rm.ind=NULL, list.seqs = NULL){ + if(!is.null(onemap.obj)){ + if(!inherits(onemap.obj, "onemap")) stop("Input must to be of onemap class \n") + if(!(length(which(rownames(onemap.obj$geno) %in% rm.ind)) >0)) stop("We could not find any of these individuals in the dataset \n") + + new.onemap.obj <- onemap.obj + new.onemap.obj$geno <- onemap.obj$geno[-which(rownames(onemap.obj$geno) %in% rm.ind),] + new.onemap.obj$n.ind <- onemap.obj$n.ind - length(rm.ind) + for(i in 1:length(rm.ind)){ + rm.idx <- grep(paste0("_",rm.ind[i],"$"), rownames(new.onemap.obj$error)) + new.onemap.obj$error <- new.onemap.obj$error[-rm.idx,] + } + return(new.onemap.obj) + } else if(!is.null(list.seqs)){ + new.onemap.obj <- list.seqs[[1]]$data.name + if(!(length(which(rownames(new.onemap.obj$geno) %in% rm.ind)) >0)) stop("We could not find any of these individuals in the dataset \n") + + new.onemap.obj$geno <- new.onemap.obj$geno[-which(rownames(new.onemap.obj$geno) %in% rm.ind),] + new.onemap.obj$n.ind <- new.onemap.obj$n.ind - length(rm.ind) + for(i in 1:length(rm.ind)){ + rm.idx <- grep(paste0("_",rm.ind[i],"$"), rownames(new.onemap.obj$error)) + new.onemap.obj$error <- new.onemap.obj$error[-rm.idx,] + } + + new.list.seqs <- list.seqs + for(i in 1:length(list.seqs)){ + new.list.seqs[[i]]$data.name <- new.onemap.obj + } + return(new.list.seqs) + } else { + stop("Please, indicate an onemap object or a list of sequences using onemap.obj and list.seqs arguments.") } - return(new.onemap.obj) } #' Sort markers in onemap object by their position in reference genome diff --git a/man/remove_inds.Rd b/man/remove_inds.Rd index e61d898..add3338 100644 --- a/man/remove_inds.Rd +++ b/man/remove_inds.Rd @@ -4,32 +4,19 @@ \alias{remove_inds} \title{Remove individuals from the onemap object} \usage{ -remove_inds(onemap.obj, rm.ind) +remove_inds(onemap.obj = NULL, rm.ind = NULL, list.seqs = NULL) } \arguments{ \item{onemap.obj}{object of class onemap} \item{rm.ind}{vector of characters with individuals names} + +\item{list.seqs}{list of objects of class sequence} } \value{ -An object of class \code{onemap} without the selected individuals, -i.e., a list with the following -components: \item{geno}{a matrix with integers indicating the genotypes -read for each marker. Each column contains data for a marker and each row -represents an individual.} \item{n.ind}{number of individuals.} -\item{n.mar}{number of markers.} \item{segr.type}{a vector with the -segregation type of each marker, as \code{strings}.} \item{segr.type.num}{a -vector with the segregation type of each marker, represented in a -simplified manner as integers, i.e. 1 corresponds to markers of type -\code{"A"}; 2 corresponds to markers of type \code{"B1.5"}; 3 corresponds -to markers of type \code{"B2.6"}; 4 corresponds to markers of type -\code{"B3.7"}; 5 corresponds to markers of type \code{"C.8"}; 6 corresponds -to markers of type \code{"D1"} and 7 corresponds to markers of type -\code{"D2"}. Markers for F2 intercrosses are coded as 1; all other crosses -are left as \code{NA}.} \item{input}{the name of the input file.} -\item{n.phe}{number of phenotypes.} \item{pheno}{a matrix with phenotypic -values. Each column contains data for a trait and each row represents an -individual.} +An object of class \code{onemap} without the selected individuals +if onemap object is used as input, or a list of objects of class \code{sequence} +without the selected individuals if a list of sequences objects is use as input } \description{ Remove individuals from the onemap object diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 0a555ae..a6fb73e 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -2,7 +2,7 @@ context("Utils functions") test_that("Combine and split datasets", { - check_combine <- function(data1, data2, n.ind, n.mks, n_mk.end){ + check_combine <- function(data1, data2, n.ind, n.mks, n_mk.end, rm_ind){ eval(bquote(data(.(data1)))) eval(bquote(data(.(data2)))) @@ -38,31 +38,39 @@ test_that("Combine and split datasets", { n_mk <- dim(new.seqs[[1]]$twopt$data.name$geno)[2] eval(bquote(expect_equal(n_mk, .(n_mk.end)))) + + obj_up <- eval(bquote(remove_inds(out_filt, rm.ind = .(rm_ind)))) + + obj_up <- eval(bquote(remove_inds(rm.ind = .(rm_ind), list.seqs = list.sequences))) } check_combine(data1 = "onemap_example_out", data2 = "vcf_example_out", n.ind = 100, n.mks = 54, - n_mk.end = 23) + n_mk.end = 23, + rm_ind = "IND2") check_combine(data1 = "onemap_example_f2", data2 = "vcf_example_f2", n.ind = 200, n.mks = 91, - n_mk.end = 23) + n_mk.end = 23, + rm_ind = "IND2") check_combine(data1 = "onemap_example_bc", data2 = "vcf_example_bc", n.ind = 150, n.mks = 92, - n_mk.end = 23) + n_mk.end = 23, + rm_ind = "ID2") check_combine(data1 = "onemap_example_riself", data2 = "vcf_example_riself", n.ind = 100, n.mks = 93, - n_mk.end = 23) + n_mk.end = 23, + rm_ind = "ID2") }) From 32eb5b0ed2e84aa7a1399b56ad75bc3a536b6d59 Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Sun, 23 Apr 2023 17:35:15 -0500 Subject: [PATCH 03/36] building function #63 --- R/export_functions.R | 32 +++++++++++++++++++++++++++++ R/onemap_read_vcfR.R | 19 ++++++++--------- R/utils.R | 20 +++++++++++++++++- tests/testthat/test-input_reading.R | 21 +++++++++++++++---- 4 files changed, 77 insertions(+), 15 deletions(-) create mode 100644 R/export_functions.R diff --git a/R/export_functions.R b/R/export_functions.R new file mode 100644 index 0000000..c2a5ccf --- /dev/null +++ b/R/export_functions.R @@ -0,0 +1,32 @@ +#' Export OneMap maps to be visualized in VIEWpoly +#' +#' @param seqs.list a list with `sequence` objects +#' +#' @return object of class viewmap +#' +#' @export +export_viewpoly <- function(seqs.list){ + ph.p1 <- ph.p2 <- maps <- list() + for(i in 1:length(seqs.list)){ + parents <- parents_haplotypes(seqs.list[[i]]) + ph.p1[[i]] <- parents[,c(5,6)] + ph.p2[[i]] <- parents[,c(7,8)] + chr <- seqs.list[[i]]$data.name$CHROM[seqs.list[[i]]$seq.num] + pos <- seqs.list[[i]]$data.name$POS[seqs.list[[i]]$seq.num] + + maps[[i]] <- data.frame(mk.names = colnames(seqs.list[[i]]$data.name$geno)[seqs.list[[i]]$seq.num], + l.dist = c(0,cumsum(kosambi(seqs.list[[i]]$seq.rf))), + g.chr = if(is.null(chr)) rep(NA, length(seqs.list[[i]]$seq.num)) else chr, + g.dist = if(is.null(pos)) rep(NA, length(seqs.list[[i]]$seq.num)) else pos, + alt = rep(NA, length(seqs.list[[i]]$seq.num)), + ref = rep(NA, length(seqs.list[[i]]$seq.num))) + } + + structure(list(d.p1 = NULL, + d.p2 = NULL, + ph.p1, + ph.p2, + maps, + software = "onemap"), + class = "viewmap") +} diff --git a/R/onemap_read_vcfR.R b/R/onemap_read_vcfR.R index 36ce98a..a0d7b8a 100644 --- a/R/onemap_read_vcfR.R +++ b/R/onemap_read_vcfR.R @@ -124,29 +124,29 @@ onemap_read_vcfR <- function(vcf=NULL, # Checking marker segregation according with parents P1 <- which(dimnames(vcfR.obj@gt)[[2]]==parent1) -1 P2 <- which(dimnames(vcfR.obj@gt)[[2]]==parent2) -1 + if(length(P1)==0 | length(P2)==0) stop("One or both parents names could not be found in your data") MKS <- vcfR.obj@fix[,3] if (any(MKS == "." | is.na(MKS))) { MKS <- paste0(vcfR.obj@fix[,1],"_", vcfR.obj@fix[,2]) # Add tag if is duplicated positions (split form of mnps) - z <- 1 - for(i in 2:length(MKS)) { - if(MKS[i] == paste0(strsplit(MKS[i-1], "_")[[1]][1:2], collapse = "_")) { - z <- z + 1 - MKS[i] <- paste0(MKS[i], "_",z) - } + if(any(duplicated(MKS))){ + z <- 1 + for(i in 2:length(MKS)) { + if(MKS[i] == paste0(strsplit(MKS[i-1], "_")[[1]][1:2], collapse = "_")) { + z <- z + 1 + MKS[i] <- paste0(MKS[i], "_",z) + } + } } } # Geno matrix GT_matrix <- extract.gt(vcfR.obj) - if(length(P1)==0 | length(P2)==0) stop("One or both parents names could not be found in your data") - # This function do not consider phased genotypes GT_matrix[grep("[.]", GT_matrix)] <- "./." GT_matrix[is.na(GT_matrix)] <- "./." - GT_names <- names(table(GT_matrix)) phased <- any(grepl("[|]", GT_names)) if(phased) @@ -157,7 +157,6 @@ onemap_read_vcfR <- function(vcf=NULL, max.alleles <- max(as.numeric(do.call(c, GT_names_up[-1]))) if(phased){ - if(length(grep("[.]", GT_names_up)) > 0){ idx.mis <- grep("[.]", GT_names_up) GT_names_up[[idx.mis]] <- 0 # avoiding warning diff --git a/R/utils.R b/R/utils.R index f1d03f8..c51cac1 100644 --- a/R/utils.R +++ b/R/utils.R @@ -5,7 +5,7 @@ # File: utils.R # # Contains: acum seq_by_type map_avoid_unlinked split_2pts # # map_save_ram remove_inds sort_by_pos empty_onemap_obj # -# try_seq_by_seq add_redundants rm_dupli_mks # +# try_seq_by_seq add_redundants rm_dupli_mks ord_by_geno # # # # Written by Gabriel Rodrigues Alves Margarido and Cristiane Taniguti # # copyright (c) 2007-9, Gabriel R A Margarido # @@ -631,3 +631,21 @@ keep_only_selected_mks <- function(list.sequences= NULL){ return(new_seqs) } + +#' Order the markers in a sequence using the genomic position +#' +#' @param input.seq object of class `sequence` +#' +#' @return An object of class \code{sequence} +#' +#' @author Cristiane Taniguti +#' +#' @export +ord_by_geno <- function(input.seq){ + chrs <- input.seq$data.name$CHROM[input.seq$seq.num] + if(length(unique(chrs)) > 1) stop("Markers belong to more than one chromosome. It is only possible o order by genomic position markers belonging to same chromosome.") + ord.seq <- input.seq$seq.num[order(input.seq$data.name$POS[input.seq$seq.num])] + new.seq <- make_seq(twopts, ord.seq) + return(new.seq) +} + diff --git a/tests/testthat/test-input_reading.R b/tests/testthat/test-input_reading.R index d64ae5d..e773d9f 100644 --- a/tests/testthat/test-input_reading.R +++ b/tests/testthat/test-input_reading.R @@ -73,7 +73,7 @@ test_that("reading files",{ dim.geno = c(100,68), table.geno = c(597, 3229,2974), error1.4 = c(0.00001, rep(0.99999,3))) - + data <- onemap_read_vcfR(vcf = system.file("extdata/vcf_example_bc.vcf.gz", package = "onemap"), cross = "f2 backcross", parent1 = "P1", parent2 = "P2", output_info_rds = "test.rds") expect_equal(check_data(data), 0) @@ -97,22 +97,23 @@ test_that("reading files",{ error1.4 = c(rep(10^(-5),4))) # Test onemap_read_vcfR with simulated data - check_read_vcf <- function(df, cross, parent1, parent2, mk.types, genos){ + check_read_vcf <- function(df, cross, parent1, parent2, mk.types, dist, genos){ eval(bquote(data <- onemap_read_vcfR(vcf = .(df), cross = .(cross), parent1 = .(parent1), parent2 = .(parent2), only_biallelic = F))) expect_equal(check_data(data), 0) eval(bquote(expect_equal(.(mk.types), as.numeric(table(data$segr.type))))) segre <- test_segregation(data, simulate.p.value = T) - expect_equal(length(select_segreg(segre, distorted = T)) == 0, TRUE) + eval(bquote(expect_equal(length(select_segreg(segre, distorted = T)) == .(dist), TRUE))) eval(bquote(expect_equal(.(genos), as.numeric(table(data$geno))))) } - + check_read_vcf(df= system.file("extdata/simu_cod_out.vcf.gz", package = "onemap"), parent1 = "P1", parent2 = "P2", cross = "outcross", mk.types = rep(8,7), + dist = 0, genos = c(4381, 4853, 1173, 793)) @@ -121,6 +122,7 @@ test_that("reading files",{ parent2 = "P1", cross = "outcross", mk.types = rep(8,7), + dist = 0, genos = c(4381, 4801 , 1225, 793)) @@ -129,6 +131,7 @@ test_that("reading files",{ parent2 = "P2", cross = "f2 intercross", mk.types = 54, + dist = 0, genos = c(2667, 5358, 2829)) check_read_vcf(df= system.file("extdata/simu_cod_f2.vcf.gz", package = "onemap"), @@ -136,7 +139,17 @@ test_that("reading files",{ parent2 = "P1", cross = "f2 intercross", mk.types = 54, + dist = 0, genos = c(2829, 5358, 2667)) + + check_read_vcf(df = system.file("extdata/vcf_example_riself.vcf.gz", package = "onemap"), + parent1 = "P2", + parent2 = "P1", + cross = "ri self", + mk.types = 25, + dist = 2, + genos = c(87, 1121, 1092)) + }) test_that("writting files", { From 54ff189c567ce90c72084025e6ae5aa5ae535cdc Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Mon, 24 Apr 2023 13:08:33 -0500 Subject: [PATCH 04/36] export QTLpoly input #64 --- NAMESPACE | 3 +++ R/export_functions.R | 41 ++++++++++++++++++++++++++++++++++ R/utils.R | 4 +--- man/export_mappoly_genoprob.Rd | 17 ++++++++++++++ man/export_viewpoly.Rd | 17 ++++++++++++++ man/ord_by_geno.Rd | 20 +++++++++++++++++ 6 files changed, 99 insertions(+), 3 deletions(-) create mode 100644 man/export_mappoly_genoprob.Rd create mode 100644 man/export_viewpoly.Rd create mode 100644 man/ord_by_geno.Rd diff --git a/NAMESPACE b/NAMESPACE index 14651e5..21f08a5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -34,6 +34,8 @@ export(draw_map2) export(drop_marker) export(empty_onemap_obj) export(est_map_hmm_out) +export(export_mappoly_genoprob) +export(export_viewpoly) export(extract_depth) export(filter_2pts_gaps) export(filter_missing) @@ -52,6 +54,7 @@ export(map_overlapping_batches) export(marker_type) export(mds_onemap) export(onemap_read_vcfR) +export(ord_by_geno) export(order_seq) export(parents_haplotypes) export(pick_batch_sizes) diff --git a/R/export_functions.R b/R/export_functions.R index c2a5ccf..5f0b3b3 100644 --- a/R/export_functions.R +++ b/R/export_functions.R @@ -30,3 +30,44 @@ export_viewpoly <- function(seqs.list){ software = "onemap"), class = "viewmap") } + +#' Export genotype probabilities in MAPpoly format (input for QTLpoly) +#' +#' @param input.map object of class `sequence` +#' +#' @return object of class `mappoly.genoprob` +#' +#' @export +export_mappoly_genoprob <- function(input.map){ + probs <- cbind(ind = rep(1:input.map$data.name$n.ind, each = length(input.map$seq.num)), + marker = rep(colnames(input.map$data.name$geno)[input.map$seq.num], input.map$data.name$n.ind), + pos = c(0,cumsum(kosambi(input.map$seq.rf))), + as.data.frame(t(input.map$probs))) + + if(inherits(input.map$data.name, "outcross") | inherits(input.map$data.name, "f2")){ + phase <- list('1' = c(1,2,3,4), + '2' = c(2,1,4,3), + '3' = c(3,4,1,2), + "4" = c(4,3,2,1)) + + seq.phase <- rep(c(1,input.map$seq.phases), input.map$data.name$n.ind) + + # Adjusting phases + for(i in 1:length(seq.phase)) + probs[i,4:7] <- probs[i,phase[[seq.phase[i]]]+3] + } + + colnames(probs)[4:7] <- c("a:c", "a:d", "b:c", "b:d") + + genoprob <- array(unlist(t(probs[,4:7])), + dim = c(4, length(input.map$seq.num), input.map$data.name$n.ind), + dimnames = list(c("a:c", "a:d", "b:c", "b:d"), + colnames(input.map$data.name$geno)[input.map$seq.num], + rownames(input.map$data.name$geno))) + + map <- cumsum(c(0,kosambi(input.map$seq.rf))) + names(map) <- colnames(input.map$data.name$geno)[input.map$seq.num] + structure(list(probs = genoprob, + map = map), + class = "mappoly.genoprob") +} diff --git a/R/utils.R b/R/utils.R index c51cac1..b3c8d23 100644 --- a/R/utils.R +++ b/R/utils.R @@ -642,9 +642,7 @@ keep_only_selected_mks <- function(list.sequences= NULL){ #' #' @export ord_by_geno <- function(input.seq){ - chrs <- input.seq$data.name$CHROM[input.seq$seq.num] - if(length(unique(chrs)) > 1) stop("Markers belong to more than one chromosome. It is only possible o order by genomic position markers belonging to same chromosome.") - ord.seq <- input.seq$seq.num[order(input.seq$data.name$POS[input.seq$seq.num])] + ord.seq <- input.seq$seq.num[order(input.seq$data.name$CHROM[input.seq$seq.num],input.seq$data.name$POS[input.seq$seq.num])] new.seq <- make_seq(twopts, ord.seq) return(new.seq) } diff --git a/man/export_mappoly_genoprob.Rd b/man/export_mappoly_genoprob.Rd new file mode 100644 index 0000000..2efe927 --- /dev/null +++ b/man/export_mappoly_genoprob.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/export_functions.R +\name{export_mappoly_genoprob} +\alias{export_mappoly_genoprob} +\title{Export genotype probabilities in MAPpoly format (input for QTLpoly)} +\usage{ +export_mappoly_genoprob(input.map) +} +\arguments{ +\item{input.map}{object of class `sequence`} +} +\value{ +object of class `mappoly.genoprob` +} +\description{ +Export genotype probabilities in MAPpoly format (input for QTLpoly) +} diff --git a/man/export_viewpoly.Rd b/man/export_viewpoly.Rd new file mode 100644 index 0000000..a0acd49 --- /dev/null +++ b/man/export_viewpoly.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/export_functions.R +\name{export_viewpoly} +\alias{export_viewpoly} +\title{Export OneMap maps to be visualized in VIEWpoly} +\usage{ +export_viewpoly(seqs.list) +} +\arguments{ +\item{seqs.list}{a list with `sequence` objects} +} +\value{ +object of class viewmap +} +\description{ +Export OneMap maps to be visualized in VIEWpoly +} diff --git a/man/ord_by_geno.Rd b/man/ord_by_geno.Rd new file mode 100644 index 0000000..d022062 --- /dev/null +++ b/man/ord_by_geno.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{ord_by_geno} +\alias{ord_by_geno} +\title{Order the markers in a sequence using the genomic position} +\usage{ +ord_by_geno(input.seq) +} +\arguments{ +\item{input.seq}{object of class `sequence`} +} +\value{ +An object of class \code{sequence} +} +\description{ +Order the markers in a sequence using the genomic position +} +\author{ +Cristiane Taniguti +} From 66eb1d83dd3c7d71ef62c263e47bbdc4c2834e37 Mon Sep 17 00:00:00 2001 From: Jeekin Lau Date: Mon, 24 Apr 2023 15:35:38 -0500 Subject: [PATCH 05/36] Create plot_genome_vs_cm.R --- R/plot_genome_vs_cm.R | 75 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 75 insertions(+) create mode 100644 R/plot_genome_vs_cm.R diff --git a/R/plot_genome_vs_cm.R b/R/plot_genome_vs_cm.R new file mode 100644 index 0000000..61e7a98 --- /dev/null +++ b/R/plot_genome_vs_cm.R @@ -0,0 +1,75 @@ +####################################################################### +# # +# Package: onemap # +# # +# File: plot_genome_vs_cm.R # +# Contains: plot_genome_vs_cm # +# # +# Written by Jeekin Lau # +# copyright (c) 2023, Jeekin Lau # +# # +# First version: 04/24/2023 # +# License: GNU General Public License version 2 (June, 1991) or later # +# # +####################################################################### +##' Draws a physical vs cM map +##' +##' Provides simple genetic to physical ggplot. +##' @param map.list a map, i.e. an object of class \code{sequence} with a +##' predefined order, linkage phases, recombination fraction and likelihood; +##' also it could be a list of maps. +##' +##' @param mapping_function either "kosambi" or "haldane" +##' +##' @return ggplot with cM on x-axis and physical position on y-axis +##' +##' @author Jeekin Lau, \email{jeekinlau@@gmail.com} +##' +##' +##' @export plot_genome_vs_cm +##' +##' @import ggplot2 ggpubr + +plot_genome_vs_cm = function(map.list,mapping_function="kosambi"){ + + imf_h <- function(r) { + r[r >= 0.5] <- 0.5 - 1e-14 + -50 * log(1 - 2 * r) + } + + imf_k <- function(r) { + r[r >= 0.5] <- 0.5 - 1e-14 + 50 * atanh(2 * r) + } + + if(mapping_function=="kosambi"){ + number_chromomes = length(map.list) + plot=list() + for (i in 1:number_chromomes){ + data_for_plot = data.frame(Marker = map.list[[i]]$seq.num, + Chrom=map.list[[i]]$data.name$CHROM[map.list[[i]]$seq.num], + Position = map.list[[i]]$data.name$POS[map.list[[i]]$seq.num], + cM = cumsum(c(0,imf_k(map.list[[i]]$seq.rf)))) + plot[[i]]=ggplot(data_for_plot,mapping=aes(cM,Position))+geom_point()+ggtitle(paste0("LG ",i)) + } + + + a=ggarrange(plotlist=plot) + a + } + else{ + number_chromomes = length(map.list) + plot=list() + for (i in 1:number_chromomes){ + data_for_plot = data.frame(Marker = map.list[[i]]$seq.num, + Chrom=map.list[[i]]$data.name$CHROM[map.list[[i]]$seq.num], + Position = map.list[[i]]$data.name$POS[map.list[[i]]$seq.num], + cM = cumsum(c(0,imf_h(map.list[[i]]$seq.rf)))) + plot[[i]]=ggplot(data_for_plot,mapping=aes(cM,Position))+geom_point()+ggtitle(paste0("LG ",i)) + } + + + a=ggarrange(plotlist=plot) + a + } +} \ No newline at end of file From b3c97deec8dc34a2d374f5b9e37d17c88809df00 Mon Sep 17 00:00:00 2001 From: Jeekin Lau Date: Tue, 25 Apr 2023 12:57:21 -0500 Subject: [PATCH 06/36] add documentation roxygen --- DESCRIPTION | 174 +++++++++++++++++++-------------------- NAMESPACE | 2 + man/plot_genome_vs_cm.Rd | 24 ++++++ 3 files changed, 113 insertions(+), 87 deletions(-) create mode 100644 man/plot_genome_vs_cm.Rd diff --git a/DESCRIPTION b/DESCRIPTION index a56b02c..6d7568e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,87 +1,87 @@ -Package: onemap -Title: Construction of Genetic Maps in Experimental Crosses -Version: 3.0.0 -Description: Analysis of molecular marker data from model (backcrosses, - F2 and recombinant inbred lines) and non-model systems (i. e. - outcrossing species). For the later, it allows statistical - analysis by simultaneously estimating linkage and linkage - phases (genetic map construction) according to Wu et al. (2002) - . All analysis are based on multipoint - approaches using hidden Markov models. -Authors@R: c(person("Gabriel", - "Margarido", - role = "aut", - email = "gramarga@usp.br"), - person("Marcelo", - "Mollinari", - role = "aut"), - person("Cristiane", - "Taniguti", - role=c("ctb", "cre"), - email="chtaniguti@tamu.edu"), - person("Getulio", - "Ferreira", - role="ctb"), - person("Rodrigo", - "Amadeu", - role = "ctb"), - person("Karl", - "Broman", - role = "ctb"), - person(given = "Katharine", - family = "Preedy", - role = c("ctb", "cph"), - comment = "MDS ordering algorithm"), - person(given = "Bastian", - family = "Schiffthaler", - role = c("ctb","cph"), - comment = "HMM parallelization"), - person("Augusto", - "Garcia", - role = c("aut", "ctb"), - email = "augusto.garcia@usp.br")) -Author: Gabriel Margarido [aut], Marcelo Mollinari [aut], - Cristiane Taniguti [ctb, cre], Getulio Ferreira [ctb], - Rodrigo Amadeu [ctb], Karl Broman [ctb], - Katharine Preedy [ctb, cph] (MDS ordering algorithm), - Bastian Schiffthaler [ctb, cph] (HMM parallelization), - Augusto Garcia [aut, ctb] -LinkingTo: Rcpp (>= 0.10.5) -Depends: R (>= 3.6.0) -Imports: ggplot2 (>= 2.2.1), - plotly (>= 4.7.1), - reshape2 (>= 1.4.1), - Rcpp (>= 0.10.5), - graphics, - methods, - stats, - utils, - grDevices, - smacof, - princurve, - parallel, - dplyr, - tidyr, - htmlwidgets, - ggpubr, - RColorBrewer, - dendextend, - rebus, - vcfR (>= 1.6.0) -Suggests: - knitr (>= 1.10), - rmarkdown, - testthat, - stringr -VignetteBuilder: knitr -Encoding: UTF-8 -License: GPL-3 -URL: https://github.com/augusto-garcia/onemap -BugReports: https://github.com/augusto-garcia/onemap/wiki -Maintainer: Cristiane Taniguti -Repository: CRAN -Packaged: 2019-09-22 22:25:43 UTC; cris -NeedsCompilation: yes -Date/Publication: 2019-09-22 22:48:07 UTC -RoxygenNote: 7.1.2 -biocViews: +Package: onemap +Title: Construction of Genetic Maps in Experimental Crosses +Version: 3.0.0 +Description: Analysis of molecular marker data from model (backcrosses, + F2 and recombinant inbred lines) and non-model systems (i. e. + outcrossing species). For the later, it allows statistical + analysis by simultaneously estimating linkage and linkage + phases (genetic map construction) according to Wu et al. (2002) + . All analysis are based on multipoint + approaches using hidden Markov models. +Authors@R: c(person("Gabriel", + "Margarido", + role = "aut", + email = "gramarga@usp.br"), + person("Marcelo", + "Mollinari", + role = "aut"), + person("Cristiane", + "Taniguti", + role=c("ctb", "cre"), + email="chtaniguti@tamu.edu"), + person("Getulio", + "Ferreira", + role="ctb"), + person("Rodrigo", + "Amadeu", + role = "ctb"), + person("Karl", + "Broman", + role = "ctb"), + person(given = "Katharine", + family = "Preedy", + role = c("ctb", "cph"), + comment = "MDS ordering algorithm"), + person(given = "Bastian", + family = "Schiffthaler", + role = c("ctb","cph"), + comment = "HMM parallelization"), + person("Augusto", + "Garcia", + role = c("aut", "ctb"), + email = "augusto.garcia@usp.br")) +Author: Gabriel Margarido [aut], Marcelo Mollinari [aut], + Cristiane Taniguti [ctb, cre], Getulio Ferreira [ctb], + Rodrigo Amadeu [ctb], Karl Broman [ctb], + Katharine Preedy [ctb, cph] (MDS ordering algorithm), + Bastian Schiffthaler [ctb, cph] (HMM parallelization), + Augusto Garcia [aut, ctb] +LinkingTo: Rcpp (>= 0.10.5) +Depends: R (>= 3.6.0) +Imports: ggplot2 (>= 2.2.1), + plotly (>= 4.7.1), + reshape2 (>= 1.4.1), + Rcpp (>= 0.10.5), + graphics, + methods, + stats, + utils, + grDevices, + smacof, + princurve, + parallel, + dplyr, + tidyr, + htmlwidgets, + ggpubr, + RColorBrewer, + dendextend, + rebus, + vcfR (>= 1.6.0) +Suggests: + knitr (>= 1.10), + rmarkdown, + testthat, + stringr +VignetteBuilder: knitr +Encoding: UTF-8 +License: GPL-3 +URL: https://github.com/augusto-garcia/onemap +BugReports: https://github.com/augusto-garcia/onemap/wiki +Maintainer: Cristiane Taniguti +Repository: CRAN +Packaged: 2019-09-22 22:25:43 UTC; cris +NeedsCompilation: yes +Date/Publication: 2019-09-22 22:48:07 UTC +RoxygenNote: 7.2.3 +biocViews: diff --git a/NAMESPACE b/NAMESPACE index 14651e5..94d44d1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -56,6 +56,7 @@ export(order_seq) export(parents_haplotypes) export(pick_batch_sizes) export(plot_by_segreg_type) +export(plot_genome_vs_cm) export(progeny_haplotypes) export(progeny_haplotypes_counts) export(rcd) @@ -88,6 +89,7 @@ export(write_onemap_raw) import(Rcpp) import(dplyr) import(ggplot2) +import(ggpubr) import(graphics) import(parallel) import(princurve) diff --git a/man/plot_genome_vs_cm.Rd b/man/plot_genome_vs_cm.Rd new file mode 100644 index 0000000..95ecddb --- /dev/null +++ b/man/plot_genome_vs_cm.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot_genome_vs_cm.R +\name{plot_genome_vs_cm} +\alias{plot_genome_vs_cm} +\title{Draws a physical vs cM map} +\usage{ +plot_genome_vs_cm(map.list, mapping_function = "kosambi") +} +\arguments{ +\item{map.list}{a map, i.e. an object of class \code{sequence} with a +predefined order, linkage phases, recombination fraction and likelihood; +also it could be a list of maps.} + +\item{mapping_function}{either "kosambi" or "haldane"} +} +\value{ +ggplot with cM on x-axis and physical position on y-axis +} +\description{ +Provides simple genetic to physical ggplot. +} +\author{ +Jeekin Lau, \email{jeekinlau@gmail.com} +} From 6cca1c4ba5f82aafdd0699301f90f1381fa852e4 Mon Sep 17 00:00:00 2001 From: Jeekin Lau Date: Tue, 25 Apr 2023 13:02:35 -0500 Subject: [PATCH 07/36] update for one chromosome --- R/plot_genome_vs_cm.R | 2 +- man/plot_genome_vs_cm.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/plot_genome_vs_cm.R b/R/plot_genome_vs_cm.R index 61e7a98..a5ff077 100644 --- a/R/plot_genome_vs_cm.R +++ b/R/plot_genome_vs_cm.R @@ -17,7 +17,7 @@ ##' Provides simple genetic to physical ggplot. ##' @param map.list a map, i.e. an object of class \code{sequence} with a ##' predefined order, linkage phases, recombination fraction and likelihood; -##' also it could be a list of maps. +##' also it could be a list of maps. If you want to plot a single map sequence then run `plot_genome_vs_cm(list(map_of_chromosome))` ##' ##' @param mapping_function either "kosambi" or "haldane" ##' diff --git a/man/plot_genome_vs_cm.Rd b/man/plot_genome_vs_cm.Rd index 95ecddb..8f3e9de 100644 --- a/man/plot_genome_vs_cm.Rd +++ b/man/plot_genome_vs_cm.Rd @@ -9,7 +9,7 @@ plot_genome_vs_cm(map.list, mapping_function = "kosambi") \arguments{ \item{map.list}{a map, i.e. an object of class \code{sequence} with a predefined order, linkage phases, recombination fraction and likelihood; -also it could be a list of maps.} +also it could be a list of maps. If you want to plot a single map sequence then run `plot_genome_vs_cm(list(map_of_chromosome))`} \item{mapping_function}{either "kosambi" or "haldane"} } From 43ff374920c116490d84bd5801ef34c5dd072cd7 Mon Sep 17 00:00:00 2001 From: Jeekin Lau Date: Wed, 26 Apr 2023 14:14:10 -0500 Subject: [PATCH 08/36] fixed kosambi and haldane and checks for sequence or list --- R/plot_genome_vs_cm.R | 17 ++++++----------- man/plot_genome_vs_cm.Rd | 2 +- 2 files changed, 7 insertions(+), 12 deletions(-) diff --git a/R/plot_genome_vs_cm.R b/R/plot_genome_vs_cm.R index a5ff077..1b240bf 100644 --- a/R/plot_genome_vs_cm.R +++ b/R/plot_genome_vs_cm.R @@ -17,7 +17,7 @@ ##' Provides simple genetic to physical ggplot. ##' @param map.list a map, i.e. an object of class \code{sequence} with a ##' predefined order, linkage phases, recombination fraction and likelihood; -##' also it could be a list of maps. If you want to plot a single map sequence then run `plot_genome_vs_cm(list(map_of_chromosome))` +##' also it could be a list of maps. ##' ##' @param mapping_function either "kosambi" or "haldane" ##' @@ -32,15 +32,10 @@ plot_genome_vs_cm = function(map.list,mapping_function="kosambi"){ - imf_h <- function(r) { - r[r >= 0.5] <- 0.5 - 1e-14 - -50 * log(1 - 2 * r) - } + if(!(inherits(map.list,c("list", "sequence")))) stop(deparse(substitute(map.list))," is not an object of class 'list' or 'sequnece'") - imf_k <- function(r) { - r[r >= 0.5] <- 0.5 - 1e-14 - 50 * atanh(2 * r) - } + ## if map.list is just a single chormosome, convert it into a list + if(inherits(map.list,"sequence")) map.list<-list(map.list) if(mapping_function=="kosambi"){ number_chromomes = length(map.list) @@ -49,7 +44,7 @@ plot_genome_vs_cm = function(map.list,mapping_function="kosambi"){ data_for_plot = data.frame(Marker = map.list[[i]]$seq.num, Chrom=map.list[[i]]$data.name$CHROM[map.list[[i]]$seq.num], Position = map.list[[i]]$data.name$POS[map.list[[i]]$seq.num], - cM = cumsum(c(0,imf_k(map.list[[i]]$seq.rf)))) + cM = cumsum(c(0,kosambi(map.list[[i]]$seq.rf)))) plot[[i]]=ggplot(data_for_plot,mapping=aes(cM,Position))+geom_point()+ggtitle(paste0("LG ",i)) } @@ -64,7 +59,7 @@ plot_genome_vs_cm = function(map.list,mapping_function="kosambi"){ data_for_plot = data.frame(Marker = map.list[[i]]$seq.num, Chrom=map.list[[i]]$data.name$CHROM[map.list[[i]]$seq.num], Position = map.list[[i]]$data.name$POS[map.list[[i]]$seq.num], - cM = cumsum(c(0,imf_h(map.list[[i]]$seq.rf)))) + cM = cumsum(c(0,haldane(map.list[[i]]$seq.rf)))) plot[[i]]=ggplot(data_for_plot,mapping=aes(cM,Position))+geom_point()+ggtitle(paste0("LG ",i)) } diff --git a/man/plot_genome_vs_cm.Rd b/man/plot_genome_vs_cm.Rd index 8f3e9de..95ecddb 100644 --- a/man/plot_genome_vs_cm.Rd +++ b/man/plot_genome_vs_cm.Rd @@ -9,7 +9,7 @@ plot_genome_vs_cm(map.list, mapping_function = "kosambi") \arguments{ \item{map.list}{a map, i.e. an object of class \code{sequence} with a predefined order, linkage phases, recombination fraction and likelihood; -also it could be a list of maps. If you want to plot a single map sequence then run `plot_genome_vs_cm(list(map_of_chromosome))`} +also it could be a list of maps.} \item{mapping_function}{either "kosambi" or "haldane"} } From be0a1f5241895bbb1dd561328949c11c747ee950 Mon Sep 17 00:00:00 2001 From: Jeekin Lau Date: Wed, 17 May 2023 12:54:53 -0500 Subject: [PATCH 09/36] add summary_maps function --- NAMESPACE | 1 + R/summary_maps.R | 65 +++++++++++++++++++++++++++++++++++++++++++++ man/summary_maps.Rd | 24 +++++++++++++++++ 3 files changed, 90 insertions(+) create mode 100644 R/summary_maps.R create mode 100644 man/summary_maps.Rd diff --git a/NAMESPACE b/NAMESPACE index 94d44d1..bf49a41 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -78,6 +78,7 @@ export(sort_by_pos) export(split_2pts) export(split_onemap) export(suggest_lod) +export(summary_maps) export(test_segregation) export(test_segregation_of_a_marker) export(try_seq) diff --git a/R/summary_maps.R b/R/summary_maps.R new file mode 100644 index 0000000..da0a6fd --- /dev/null +++ b/R/summary_maps.R @@ -0,0 +1,65 @@ +####################################################################### +# # +# Package: onemap # +# # +# File: summary_maps.R # +# Contains: summary_maps # +# # +# Written by Jeekin Lau # +# copyright (c) 2023, Jeekin Lau # +# # +# First version: 04/24/2023 # +# License: GNU General Public License version 2 (June, 1991) or later # +# # +####################################################################### +##' Draws a physical vs cM map +##' +##' Provides simple genetic to physical ggplot. +##' @param map.list a map, i.e. an object of class \code{sequence} with a +##' predefined order, linkage phases, recombination fraction and likelihood; +##' also it could be a list of maps. +##' +##' @param mapping_function either "kosambi" or "haldane" +##' +##' @return dataframe with basic summary statistics +##' +##' @author Jeekin Lau, \email{jeekinlau@@gmail.com} +##' +##' +##' @export summary_maps +##' +##' +##' +##' +summary_maps = function(map.list,mapping_function="kosambi"){ + + + if(!(inherits(map.list,c("list", "sequence")))) stop(deparse(substitute(map.list))," is not an object of class 'list' or 'sequnece'") + ## if map.list is just a single chormosome, convert it into a list + if(inherits(map.list,"sequence")) map.list<-list(map.list) + + + if(mapping_function=="kosambi"){ + summary=data.frame(LG = 1:length(map.list), + nMrks = unlist(lapply(map.list, function(x) length(x$seq.num))), + map_length = unlist(lapply(map.list, function(x) sum(c(0,kosambi(x$seq.rf))))), + max_gap = unlist(lapply(map.list, function(x) kosambi(max(x$seq.rf))))) + + + last_line=data.frame(LG="All", nMrks=sum(summary$nMrks), map_length=sum(summary$map_length),max_gap=max(summary$max_gap)) + + stats=rbind(summary,last_line) + } + if(mapping_function=="haldane"){ + summary=data.frame(LG = 1:length(map.list), + nMrks = unlist(lapply(map.list, function(x) length(x$seq.num))), + map_length = unlist(lapply(map.list, function(x) sum(c(0,haldane(x$seq.rf))))), + max_gap = unlist(lapply(map.list, function(x) haldane(max(x$seq.rf))))) + + + last_line=data.frame(LG="All", nMrks=sum(summary$nMrks), map_length=sum(summary$map_length),max_gap=max(summary$max_gap)) + + stats=rbind(summary,last_line) + } + return(stats) +} \ No newline at end of file diff --git a/man/summary_maps.Rd b/man/summary_maps.Rd new file mode 100644 index 0000000..d426e43 --- /dev/null +++ b/man/summary_maps.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary_maps.R +\name{summary_maps} +\alias{summary_maps} +\title{Draws a physical vs cM map} +\usage{ +summary_maps(map.list, mapping_function = "kosambi") +} +\arguments{ +\item{map.list}{a map, i.e. an object of class \code{sequence} with a +predefined order, linkage phases, recombination fraction and likelihood; +also it could be a list of maps.} + +\item{mapping_function}{either "kosambi" or "haldane"} +} +\value{ +dataframe with basic summary statistics +} +\description{ +Provides simple genetic to physical ggplot. +} +\author{ +Jeekin Lau, \email{jeekinlau@gmail.com} +} From 3580e4aad1bb4184287cc6c9175cb53a4681ad01 Mon Sep 17 00:00:00 2001 From: Jeekin Lau Date: Thu, 18 May 2023 13:26:28 -0500 Subject: [PATCH 10/36] rename to summary_maps_onemap --- NAMESPACE | 2 +- R/summary_maps.R | 6 +++--- man/{summary_maps.Rd => summary_maps_onemap.Rd} | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) rename man/{summary_maps.Rd => summary_maps_onemap.Rd} (82%) diff --git a/NAMESPACE b/NAMESPACE index bf49a41..46da3ee 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -78,7 +78,7 @@ export(sort_by_pos) export(split_2pts) export(split_onemap) export(suggest_lod) -export(summary_maps) +export(summary_maps_onemap) export(test_segregation) export(test_segregation_of_a_marker) export(try_seq) diff --git a/R/summary_maps.R b/R/summary_maps.R index da0a6fd..6a4a88d 100644 --- a/R/summary_maps.R +++ b/R/summary_maps.R @@ -3,7 +3,7 @@ # Package: onemap # # # # File: summary_maps.R # -# Contains: summary_maps # +# Contains: summary_maps_onemap # # # # Written by Jeekin Lau # # copyright (c) 2023, Jeekin Lau # @@ -26,12 +26,12 @@ ##' @author Jeekin Lau, \email{jeekinlau@@gmail.com} ##' ##' -##' @export summary_maps +##' @export summary_maps_onemap ##' ##' ##' ##' -summary_maps = function(map.list,mapping_function="kosambi"){ +summary_maps_onemap = function(map.list,mapping_function="kosambi"){ if(!(inherits(map.list,c("list", "sequence")))) stop(deparse(substitute(map.list))," is not an object of class 'list' or 'sequnece'") diff --git a/man/summary_maps.Rd b/man/summary_maps_onemap.Rd similarity index 82% rename from man/summary_maps.Rd rename to man/summary_maps_onemap.Rd index d426e43..b24c00e 100644 --- a/man/summary_maps.Rd +++ b/man/summary_maps_onemap.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary_maps.R -\name{summary_maps} -\alias{summary_maps} +\name{summary_maps_onemap} +\alias{summary_maps_onemap} \title{Draws a physical vs cM map} \usage{ -summary_maps(map.list, mapping_function = "kosambi") +summary_maps_onemap(map.list, mapping_function = "kosambi") } \arguments{ \item{map.list}{a map, i.e. an object of class \code{sequence} with a From b9b959eb4e9837528bcfb86d386f31a0c312c0a1 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Sat, 24 Jun 2023 08:02:53 -0500 Subject: [PATCH 11/36] bugifx --- R/map.R | 5 ++++- R/utils.R | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/R/map.R b/R/map.R index 24b5bb0..c3faa72 100644 --- a/R/map.R +++ b/R/map.R @@ -319,7 +319,8 @@ map <- function(input.seq,tol=10E-5, verbose=FALSE, while(final.map$loglike == -Inf){ idx <- idx + 1 tol.up <- tol*(idx*10) - warning(paste0("HMM likelihood returned with this tolerance was -Inf. Tolerance used:", tol.up)) + warning("The EM tolerance was increased.") + cat(paste0("HMM likelihood returned with this tolerance was -Inf. Tolerance used:", tol.up)) final.map <- est_map_hmm_out(geno=t(input.seq$data.name$geno[,seq.num]), error = input.seq$data.name$error[seq.num + rep(c(0:(input.seq$data.name$n.ind-1))*input.seq$data.name$n.mar, @@ -330,6 +331,8 @@ map <- function(input.seq,tol=10E-5, verbose=FALSE, verbose=FALSE, tol=tol.up) + if(is.na(final.map$loglike)) final.map$loglike <- -Inf + } return(structure(list(seq.num=seq.num, seq.phases=seq.phases, seq.rf=final.map$rf, diff --git a/R/utils.R b/R/utils.R index b3c8d23..a1967a8 100644 --- a/R/utils.R +++ b/R/utils.R @@ -643,7 +643,7 @@ keep_only_selected_mks <- function(list.sequences= NULL){ #' @export ord_by_geno <- function(input.seq){ ord.seq <- input.seq$seq.num[order(input.seq$data.name$CHROM[input.seq$seq.num],input.seq$data.name$POS[input.seq$seq.num])] - new.seq <- make_seq(twopts, ord.seq) + new.seq <- make_seq(input.seq$data.name$twopts, ord.seq) return(new.seq) } From 56d5f7c84d4f891eb0e8321a5a39788c42f01768 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Mon, 26 Jun 2023 11:10:10 -0500 Subject: [PATCH 12/36] bugifx --- R/onemap_read_vcfR.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/R/onemap_read_vcfR.R b/R/onemap_read_vcfR.R index a0d7b8a..d647bdc 100644 --- a/R/onemap_read_vcfR.R +++ b/R/onemap_read_vcfR.R @@ -82,7 +82,7 @@ ##'@export onemap_read_vcfR <- function(vcf=NULL, vcfR.object = NULL, - cross = c("outcross", "f2 intercross", "f2 backcross", "ri self", "ri sib"), + cross = NULL, parent1 =NULL, parent2 =NULL, f1=NULL, @@ -101,6 +101,8 @@ onemap_read_vcfR <- function(vcf=NULL, vcfR.obj <- read.vcfR(vcf, verbose = F) } else vcfR.obj <- vcfR.object + if(is.null(cross)) stop("Define a cross type: outcross, f2 intercross, f2 backcross, ri self, ri sib") + n.mk <- dim(vcfR.obj@gt)[1] n.ind <- dim(vcfR.obj@gt)[2]-1 INDS <- dimnames(vcfR.obj@gt)[[2]][-1] @@ -148,11 +150,12 @@ onemap_read_vcfR <- function(vcf=NULL, GT_matrix[grep("[.]", GT_matrix)] <- "./." GT_matrix[is.na(GT_matrix)] <- "./." + GT_names <- names(table(GT_matrix)) + phased <- any(grepl("[|]", GT_names)) if(phased) GT_matrix <- gsub("[|]", "/", as.matrix(GT_matrix)) - GT_names <- names(table(GT_matrix)) GT_names_up <- strsplit(GT_names, "/") max.alleles <- max(as.numeric(do.call(c, GT_names_up[-1]))) From 088c27af2baa2885bf5cb2d2112e2451602a449e Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Wed, 28 Jun 2023 11:06:41 -0500 Subject: [PATCH 13/36] edit cMxMb plot --- R/plot_genome_vs_cm.R | 57 ++++++++++++++++------------------------ man/onemap_read_vcfR.Rd | 2 +- man/plot_genome_vs_cm.Rd | 4 ++- 3 files changed, 26 insertions(+), 37 deletions(-) diff --git a/R/plot_genome_vs_cm.R b/R/plot_genome_vs_cm.R index 1b240bf..23ec8a5 100644 --- a/R/plot_genome_vs_cm.R +++ b/R/plot_genome_vs_cm.R @@ -5,7 +5,8 @@ # File: plot_genome_vs_cm.R # # Contains: plot_genome_vs_cm # # # -# Written by Jeekin Lau # +# Written by Jeekin Lau with minor # +# modifications by Cristiane Taniguti # # copyright (c) 2023, Jeekin Lau # # # # First version: 04/24/2023 # @@ -21,50 +22,36 @@ ##' ##' @param mapping_function either "kosambi" or "haldane" ##' +##' @param group.names vector with group name for each sequence object in the map.list +##' ##' @return ggplot with cM on x-axis and physical position on y-axis ##' ##' @author Jeekin Lau, \email{jeekinlau@@gmail.com} ##' -##' ##' @export plot_genome_vs_cm ##' ##' @import ggplot2 ggpubr - -plot_genome_vs_cm = function(map.list,mapping_function="kosambi"){ - - if(!(inherits(map.list,c("list", "sequence")))) stop(deparse(substitute(map.list))," is not an object of class 'list' or 'sequnece'") +plot_genome_vs_cm = function(map.list,mapping_function="kosambi", group.names=NULL){ + if(!(inherits(map.list,c("list", "sequence")))) stop(deparse(substitute(map.list))," is not an object of class 'list' or 'sequence'") ## if map.list is just a single chormosome, convert it into a list if(inherits(map.list,"sequence")) map.list<-list(map.list) - if(mapping_function=="kosambi"){ - number_chromomes = length(map.list) - plot=list() - for (i in 1:number_chromomes){ - data_for_plot = data.frame(Marker = map.list[[i]]$seq.num, - Chrom=map.list[[i]]$data.name$CHROM[map.list[[i]]$seq.num], - Position = map.list[[i]]$data.name$POS[map.list[[i]]$seq.num], - cM = cumsum(c(0,kosambi(map.list[[i]]$seq.rf)))) - plot[[i]]=ggplot(data_for_plot,mapping=aes(cM,Position))+geom_point()+ggtitle(paste0("LG ",i)) - } - - - a=ggarrange(plotlist=plot) - a - } - else{ - number_chromomes = length(map.list) - plot=list() - for (i in 1:number_chromomes){ - data_for_plot = data.frame(Marker = map.list[[i]]$seq.num, - Chrom=map.list[[i]]$data.name$CHROM[map.list[[i]]$seq.num], - Position = map.list[[i]]$data.name$POS[map.list[[i]]$seq.num], - cM = cumsum(c(0,haldane(map.list[[i]]$seq.rf)))) - plot[[i]]=ggplot(data_for_plot,mapping=aes(cM,Position))+geom_point()+ggtitle(paste0("LG ",i)) - } - - - a=ggarrange(plotlist=plot) - a + number_chromomes = length(map.list) + plot=list() + for (i in 1:number_chromomes){ + data_for_plot = data.frame(Marker = map.list[[i]]$seq.num, + Chrom=map.list[[i]]$data.name$CHROM[map.list[[i]]$seq.num], + Position = map.list[[i]]$data.name$POS[map.list[[i]]$seq.num], + cM = {if(mapping_function=="kosambi") { + cM =cumsum(c(0,kosambi(map.list[[i]]$seq.rf))) + } else { + cM=cumsum(c(0,haldane(map.list[[i]]$seq.rf))) + }}) + plot[[i]]=ggplot(data_for_plot,mapping=aes(cM,Position))+geom_point()+ ylab("Genomic position") + + {if(!is.null(group.names)) ggtitle(paste0("LG ",group.names[i]))} + theme_bw() } + + a=ggarrange(plotlist=plot) + return(a) } \ No newline at end of file diff --git a/man/onemap_read_vcfR.Rd b/man/onemap_read_vcfR.Rd index 3a4ca74..c0f2444 100644 --- a/man/onemap_read_vcfR.Rd +++ b/man/onemap_read_vcfR.Rd @@ -7,7 +7,7 @@ onemap_read_vcfR( vcf = NULL, vcfR.object = NULL, - cross = c("outcross", "f2 intercross", "f2 backcross", "ri self", "ri sib"), + cross = NULL, parent1 = NULL, parent2 = NULL, f1 = NULL, diff --git a/man/plot_genome_vs_cm.Rd b/man/plot_genome_vs_cm.Rd index 95ecddb..bd5d9ec 100644 --- a/man/plot_genome_vs_cm.Rd +++ b/man/plot_genome_vs_cm.Rd @@ -4,7 +4,7 @@ \alias{plot_genome_vs_cm} \title{Draws a physical vs cM map} \usage{ -plot_genome_vs_cm(map.list, mapping_function = "kosambi") +plot_genome_vs_cm(map.list, mapping_function = "kosambi", group.names = NULL) } \arguments{ \item{map.list}{a map, i.e. an object of class \code{sequence} with a @@ -12,6 +12,8 @@ predefined order, linkage phases, recombination fraction and likelihood; also it could be a list of maps.} \item{mapping_function}{either "kosambi" or "haldane"} + +\item{group.names}{vector with group name for each sequence object in the map.list} } \value{ ggplot with cM on x-axis and physical position on y-axis From 95f834c6e38939927493b9067256f109a13cc47f Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Wed, 28 Jun 2023 11:55:04 -0500 Subject: [PATCH 14/36] adding test for #66 --- R/plot_genome_vs_cm.R | 5 ++++- tests/testthat/test-filters.R | 2 ++ tests/testthat/test-utils_graphics.R | 2 +- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/R/plot_genome_vs_cm.R b/R/plot_genome_vs_cm.R index 23ec8a5..202c9cb 100644 --- a/R/plot_genome_vs_cm.R +++ b/R/plot_genome_vs_cm.R @@ -37,6 +37,9 @@ plot_genome_vs_cm = function(map.list,mapping_function="kosambi", group.names=NU ## if map.list is just a single chormosome, convert it into a list if(inherits(map.list,"sequence")) map.list<-list(map.list) + if(is.null(map.list[[1]]$data.name$POS) | is.null(map.list[[1]]$data.name$CHROM)) stop("Reference genome chromosome and position informaion is not available in the dataset.") + + number_chromomes = length(map.list) plot=list() for (i in 1:number_chromomes){ @@ -49,7 +52,7 @@ plot_genome_vs_cm = function(map.list,mapping_function="kosambi", group.names=NU cM=cumsum(c(0,haldane(map.list[[i]]$seq.rf))) }}) plot[[i]]=ggplot(data_for_plot,mapping=aes(cM,Position))+geom_point()+ ylab("Genomic position") + - {if(!is.null(group.names)) ggtitle(paste0("LG ",group.names[i]))} + theme_bw() + {if(!is.null(group.names)) ggtitle(paste0(group.names[i]))} + theme_bw() } a=ggarrange(plotlist=plot) diff --git a/tests/testthat/test-filters.R b/tests/testthat/test-filters.R index 27b778c..f38ee9a 100644 --- a/tests/testthat/test-filters.R +++ b/tests/testthat/test-filters.R @@ -42,6 +42,8 @@ test_that("number of bins",{ lg1 <- make_seq(lgs,1) map1 <- map(lg1) + plot_genome_vs_cm(map.list = map1, group.names = "LG2") + map_red <- add_redundants(sequence = map1, onemap.obj = vcf_example_out, bins) diff --git a/tests/testthat/test-utils_graphics.R b/tests/testthat/test-utils_graphics.R index 0bde260..754a5cf 100644 --- a/tests/testthat/test-utils_graphics.R +++ b/tests/testthat/test-utils_graphics.R @@ -29,7 +29,7 @@ test_that("create depth profile", { test_depth_profile(df = system.file("extdata/vcf_example_out.vcf.gz", package = "onemap"), cross = "outcross", parent1 = "P1", parent2 = "P2", n.genos.onemap = c(4,774,1077,401), - n.genos = c(774,1077,401), + n.genos = c(774,1077,401), n.genos.alt.ref.onemap = c(1077,401,774,4), n.genos.alt.ref = c(1077,401,774)) }) \ No newline at end of file From 1aaa544e8740d62f7106bdf9cd456ba4d845beb6 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Wed, 28 Jun 2023 14:43:21 -0500 Subject: [PATCH 15/36] function review #71 --- R/summary_maps.R | 62 +++++++++++++++++------------------ man/summary_maps_onemap.Rd | 6 ++-- tests/testthat/test-filters.R | 6 +++- 3 files changed, 38 insertions(+), 36 deletions(-) diff --git a/R/summary_maps.R b/R/summary_maps.R index 6a4a88d..fcf78f1 100644 --- a/R/summary_maps.R +++ b/R/summary_maps.R @@ -5,61 +5,59 @@ # File: summary_maps.R # # Contains: summary_maps_onemap # # # -# Written by Jeekin Lau # +# Written by Jeekin Lau with minor modifications # +# from Cristiane Taniguti # # copyright (c) 2023, Jeekin Lau # # # # First version: 04/24/2023 # # License: GNU General Public License version 2 (June, 1991) or later # # # ####################################################################### -##' Draws a physical vs cM map + + +##' Create table with summary information about the linkage map ##' -##' Provides simple genetic to physical ggplot. ##' @param map.list a map, i.e. an object of class \code{sequence} with a ##' predefined order, linkage phases, recombination fraction and likelihood; ##' also it could be a list of maps. ##' ##' @param mapping_function either "kosambi" or "haldane" ##' -##' @return dataframe with basic summary statistics +##' @return data.frame with basic summary statistics ##' ##' @author Jeekin Lau, \email{jeekinlau@@gmail.com} ##' +##' @import tidyr ##' ##' @export summary_maps_onemap ##' -##' -##' -##' -summary_maps_onemap = function(map.list,mapping_function="kosambi"){ +summary_maps_onemap = function(map.list, mapping_function="kosambi"){ + if(!(inherits(map.list,c("list", "sequence")))) stop(deparse(substitute(map.list))," is not an object of class 'list' or 'sequence'") - if(!(inherits(map.list,c("list", "sequence")))) stop(deparse(substitute(map.list))," is not an object of class 'list' or 'sequnece'") - ## if map.list is just a single chormosome, convert it into a list + ## if map.list is just a single chromosome, convert it into a list if(inherits(map.list,"sequence")) map.list<-list(map.list) + mk_types <- lapply(map.list, function(x) as.data.frame(table(x$data.name$segr.type[x$seq.num]))) + for(i in 1:length(mk_types)) mk_types[[i]] <- cbind(Var2=i, mk_types[[i]]) + + mk_types <- do.call(rbind, mk_types) + mk_types <- pivot_wider(mk_types, names_from = "Var1", values_from = "Freq") + mk_types[is.na(mk_types)] <- 0 + + summary=data.frame(LG = 1:length(map.list), + n_mks = unlist(lapply(map.list, function(x) length(x$seq.num))), + mk_types[,-1], + map_length = unlist(lapply(map.list, function(x) sum(c(0,kosambi(x$seq.rf))))), + max_gap = {if(mapping_function=="kosambi") { + unlist(lapply(map.list, function(x) kosambi(max(x$seq.rf)))) + } else unlist(lapply(map.list, function(x) haldane(max(x$seq.rf)))) + }) + + last_line= apply(summary, 2, sum) + + stats=rbind(summary,last_line) + stats[dim(stats)[1],1] <- "Total" - if(mapping_function=="kosambi"){ - summary=data.frame(LG = 1:length(map.list), - nMrks = unlist(lapply(map.list, function(x) length(x$seq.num))), - map_length = unlist(lapply(map.list, function(x) sum(c(0,kosambi(x$seq.rf))))), - max_gap = unlist(lapply(map.list, function(x) kosambi(max(x$seq.rf))))) - - - last_line=data.frame(LG="All", nMrks=sum(summary$nMrks), map_length=sum(summary$map_length),max_gap=max(summary$max_gap)) - - stats=rbind(summary,last_line) - } - if(mapping_function=="haldane"){ - summary=data.frame(LG = 1:length(map.list), - nMrks = unlist(lapply(map.list, function(x) length(x$seq.num))), - map_length = unlist(lapply(map.list, function(x) sum(c(0,haldane(x$seq.rf))))), - max_gap = unlist(lapply(map.list, function(x) haldane(max(x$seq.rf))))) - - - last_line=data.frame(LG="All", nMrks=sum(summary$nMrks), map_length=sum(summary$map_length),max_gap=max(summary$max_gap)) - - stats=rbind(summary,last_line) - } return(stats) } \ No newline at end of file diff --git a/man/summary_maps_onemap.Rd b/man/summary_maps_onemap.Rd index b24c00e..b472ebf 100644 --- a/man/summary_maps_onemap.Rd +++ b/man/summary_maps_onemap.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/summary_maps.R \name{summary_maps_onemap} \alias{summary_maps_onemap} -\title{Draws a physical vs cM map} +\title{Create table with summary information about the linkage map} \usage{ summary_maps_onemap(map.list, mapping_function = "kosambi") } @@ -14,10 +14,10 @@ also it could be a list of maps.} \item{mapping_function}{either "kosambi" or "haldane"} } \value{ -dataframe with basic summary statistics +data.frame with basic summary statistics } \description{ -Provides simple genetic to physical ggplot. +Create table with summary information about the linkage map } \author{ Jeekin Lau, \email{jeekinlau@gmail.com} diff --git a/tests/testthat/test-filters.R b/tests/testthat/test-filters.R index f38ee9a..e81cb54 100644 --- a/tests/testthat/test-filters.R +++ b/tests/testthat/test-filters.R @@ -41,8 +41,12 @@ test_that("number of bins",{ lgs <- group(make_seq(twopts, "all")) lg1 <- make_seq(lgs,1) map1 <- map(lg1) + map2 <- map(make_seq(lgs,4)) - plot_genome_vs_cm(map.list = map1, group.names = "LG2") + p <- plot_genome_vs_cm(map.list = map1, group.names = "LG2") + df <- summary_maps_onemap(map.list = list(map1, map2)) + + expect_equal(df$map_length[3], 159.7943, 0.1) map_red <- add_redundants(sequence = map1, onemap.obj = vcf_example_out, bins) From 7928a54d6d0480d9f9f269e9ba909174546f7b4e Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Wed, 28 Jun 2023 14:49:16 -0500 Subject: [PATCH 16/36] fix test --- tests/testthat/test-input_reading.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-input_reading.R b/tests/testthat/test-input_reading.R index e773d9f..54c9a54 100644 --- a/tests/testthat/test-input_reading.R +++ b/tests/testthat/test-input_reading.R @@ -103,7 +103,7 @@ test_that("reading files",{ only_biallelic = F))) expect_equal(check_data(data), 0) eval(bquote(expect_equal(.(mk.types), as.numeric(table(data$segr.type))))) - segre <- test_segregation(data, simulate.p.value = T) + segre <- test_segregation(data) eval(bquote(expect_equal(length(select_segreg(segre, distorted = T)) == .(dist), TRUE))) eval(bquote(expect_equal(.(genos), as.numeric(table(data$geno))))) } From d9cd913a91d3cd5f892d750c5f7436e59c4a9b44 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Wed, 28 Jun 2023 15:06:25 -0500 Subject: [PATCH 17/36] fix #73 --- R/utils.R | 6 +++++- tests/testthat/test-filters.R | 6 ++++++ 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index a1967a8..7edf2b6 100644 --- a/R/utils.R +++ b/R/utils.R @@ -642,8 +642,12 @@ keep_only_selected_mks <- function(list.sequences= NULL){ #' #' @export ord_by_geno <- function(input.seq){ + + if(!(inherits(input.seq,c("sequence")))) stop(deparse(substitute(input.seq))," is not an object of class 'sequence'") + if(is.null(input.seq$data.name$CHROM) | is.null(input.seq$data.name$POS)) stop("Reference genome chromosome and position information are not available for this dataset.") + ord.seq <- input.seq$seq.num[order(input.seq$data.name$CHROM[input.seq$seq.num],input.seq$data.name$POS[input.seq$seq.num])] - new.seq <- make_seq(input.seq$data.name$twopts, ord.seq) + new.seq <- make_seq(input.seq$twopt, ord.seq) return(new.seq) } diff --git a/tests/testthat/test-filters.R b/tests/testthat/test-filters.R index e81cb54..2065812 100644 --- a/tests/testthat/test-filters.R +++ b/tests/testthat/test-filters.R @@ -48,6 +48,12 @@ test_that("number of bins",{ expect_equal(df$map_length[3], 159.7943, 0.1) + ord1 <- ord_by_geno(make_seq(twopts, "all")) + ord2 <- ord_by_geno(map2) + + expect_equal(ord1$seq.num, 1:23) + expect_equal(ord2$seq.num, 15:23) + map_red <- add_redundants(sequence = map1, onemap.obj = vcf_example_out, bins) From f9a232e9cdc2f41fbd082e89e8d613c0e897798f Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Wed, 28 Jun 2023 15:08:52 -0500 Subject: [PATCH 18/36] update actions version --- .github/workflows/check-standard.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/check-standard.yaml b/.github/workflows/check-standard.yaml index 706b226..27fe974 100644 --- a/.github/workflows/check-standard.yaml +++ b/.github/workflows/check-standard.yaml @@ -35,7 +35,7 @@ jobs: steps: - uses: actions/checkout@v2 - - uses: r-lib/actions/setup-r@v1 + - uses: r-lib/actions/setup-r@v2 with: r-version: ${{ matrix.config.r }} From 43ea9333262a8562e56bce61343a6b3dd0c8d206 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Thu, 29 Jun 2023 11:18:03 -0500 Subject: [PATCH 19/36] fix #63 --- R/export_functions.R | 44 ++++++++++++++++++++++---- tests/testthat/test-export_functions.R | 21 ++++++++++++ 2 files changed, 59 insertions(+), 6 deletions(-) create mode 100644 tests/testthat/test-export_functions.R diff --git a/R/export_functions.R b/R/export_functions.R index 5f0b3b3..f791003 100644 --- a/R/export_functions.R +++ b/R/export_functions.R @@ -6,11 +6,39 @@ #' #' @export export_viewpoly <- function(seqs.list){ - ph.p1 <- ph.p2 <- maps <- list() + ph.p1 <- ph.p2 <- maps <- d.p1 <- d.p2 <- list() for(i in 1:length(seqs.list)){ + + # only for biallelic markers + types <- seqs.list[[i]]$data.name$segr.type[seqs.list[[i]]$seq.num] + if(inherits(seqs.list[[i]]$data.name, "outcross")){ + labs.p1 <- c("B3.7"=1, "D1.10" = 1, "D2.15" = 0) + labs.p2 <- c("B3.7"=1, "D1.10" = 0, "D2.15" = 1) + d.p1[[i]] <- labs.p1[match(types, names(labs.p1))] + d.p2[[i]] <- labs.p2[match(types, names(labs.p2))] + } else if(inherits(seqs.list[[i]]$data.name, "intercross")){ + labs <- c("A.H.B" = 1) + d.p1[[i]] <- labs[match(types, names(labs))] + d.p2[[i]] <- labs[match(types, names(labs))] + } else if(inherits(seqs.list[[i]]$data.name, "backcross")){ + labs <- c("A.H" = 1) + d.p1[[i]] <- labs[match(types, names(labs))] + labs <- c("A.H" = 0) + d.p2[[i]] <- labs[match(types, names(labs))] + } else if(inherits(seqs.list[[i]]$data.name, "ri")){ + labs <- c("A.B" = 1) + d.p1[[i]] <- labs[match(types, names(labs))] + labs <- c("A.B" = 2) + d.p2[[i]] <- labs[match(types, names(labs))] + } + parents <- parents_haplotypes(seqs.list[[i]]) ph.p1[[i]] <- parents[,c(5,6)] ph.p2[[i]] <- parents[,c(7,8)] + rownames(ph.p1[[i]]) <- rownames(ph.p2[[i]]) <- colnames(seqs.list[[i]]$data.name$geno)[seqs.list[[i]]$seq.num] + names(ph.p1[[i]]) <- c("a", "b") + names(ph.p2[[i]]) <- c("c", "d") + chr <- seqs.list[[i]]$data.name$CHROM[seqs.list[[i]]$seq.num] pos <- seqs.list[[i]]$data.name$POS[seqs.list[[i]]$seq.num] @@ -22,11 +50,11 @@ export_viewpoly <- function(seqs.list){ ref = rep(NA, length(seqs.list[[i]]$seq.num))) } - structure(list(d.p1 = NULL, - d.p2 = NULL, - ph.p1, - ph.p2, - maps, + structure(list(d.p1 = d.p1, + d.p2 = d.p2, + ph.p1 = ph.p1, + ph.p2= ph.p2, + maps = maps, software = "onemap"), class = "viewmap") } @@ -71,3 +99,7 @@ export_mappoly_genoprob <- function(input.map){ map = map), class = "mappoly.genoprob") } + + + + diff --git a/tests/testthat/test-export_functions.R b/tests/testthat/test-export_functions.R new file mode 100644 index 0000000..7aca1fd --- /dev/null +++ b/tests/testthat/test-export_functions.R @@ -0,0 +1,21 @@ +context("Export functions") + +test_that("Combine and split datasets", { + + data("vcf_example_out") + + twopts <- rf_2pts(vcf_example_out) + + seq_all <- make_seq(twopts, "all") + lgs <- group(seq_all) + lg1 <- map(make_seq(lgs,1)) + lg2 <- map(make_seq(lgs,2)) + lg3 <- map(make_seq(lgs,3)) + lg4 <- map(make_seq(lgs,4)) + + seqs.list <- list(lg1, lg2, lg3, lg4) + + viewmap.obj <- export_viewpoly(seqs.list) + + expect_equal(names(viewmap.obj), c("d.p1", "d.p2", "ph.p1", "ph.p2", "maps", "software")) +}) From a933e806bd61846bd4f9ee297d03f18bb7be692f Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Fri, 30 Jun 2023 10:08:04 -0500 Subject: [PATCH 20/36] fix #76 --- NAMESPACE | 1 + R/export_functions.R | 8 ++-- R/filters.R | 56 +++++++++++++++++++++++++- R/make_seq.R | 10 ++++- man/edit_order_onemap.Rd | 19 +++++++++ tests/testthat/test-export_functions.R | 27 +++++++++++++ tests/testthat/test-filters.R | 13 ++++-- 7 files changed, 124 insertions(+), 10 deletions(-) create mode 100644 man/edit_order_onemap.Rd diff --git a/NAMESPACE b/NAMESPACE index bb091f2..1d489f8 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -32,6 +32,7 @@ export(create_probs) export(draw_map) export(draw_map2) export(drop_marker) +export(edit_order_onemap) export(empty_onemap_obj) export(est_map_hmm_out) export(export_mappoly_genoprob) diff --git a/R/export_functions.R b/R/export_functions.R index f791003..936c166 100644 --- a/R/export_functions.R +++ b/R/export_functions.R @@ -6,6 +6,8 @@ #' #' @export export_viewpoly <- function(seqs.list){ + if(!(inherits(seqs.list,c("list", "sequence")))) stop(deparse(substitute(seqs.list))," is not an object of class 'list' or 'sequence'") + ph.p1 <- ph.p2 <- maps <- d.p1 <- d.p2 <- list() for(i in 1:length(seqs.list)){ @@ -67,6 +69,8 @@ export_viewpoly <- function(seqs.list){ #' #' @export export_mappoly_genoprob <- function(input.map){ + if(!(inherits(input.map,c("sequence")))) stop(deparse(substitute(seqs.list))," is not an object of class 'sequence'") + probs <- cbind(ind = rep(1:input.map$data.name$n.ind, each = length(input.map$seq.num)), marker = rep(colnames(input.map$data.name$geno)[input.map$seq.num], input.map$data.name$n.ind), pos = c(0,cumsum(kosambi(input.map$seq.rf))), @@ -99,7 +103,3 @@ export_mappoly_genoprob <- function(input.map){ map = map), class = "mappoly.genoprob") } - - - - diff --git a/R/filters.R b/R/filters.R index 533ba93..ba202a8 100644 --- a/R/filters.R +++ b/R/filters.R @@ -3,7 +3,7 @@ ## Package: onemap ## ## ## ## File: filters.R ## -## Contains: filter_missing filter_prob ## +## Contains: filter_missing filter_prob edit_order ## ## ## ## Written by Cristiane Taniguti ## ## copyright (c) 2007-9, Cristiane Taniguti ## @@ -131,3 +131,57 @@ filter_prob <- function(onemap.obj=NULL, threshold= 0.8, verbose=TRUE){ return(onemap.obj) } + + +#' Edit sequence ordered by reference genome positions +#' comparing to another set order +#' +#' @param input.seq object of class sequence with alternative order (not genomic order) +#' +#' @author Cristiane Taniguti, \email{chtaniguti@tamu.edu} +#' +#' @export +edit_order_onemap <- function(input.seq){ + + if (!inherits(input.seq, "sequence")) { + stop(deparse(substitute(input.seq)), " is not an object of class 'sequence'") + } + + if(unique(input.seq$data.name$CHROM[input.seq$seq.num]) > 1) stop("There are markers from more than one chromosome in the sequence.") + + get_weird <- data.frame(x = 1:length(input.seq$seq.num), + y = input.seq$data.name$POS[input.seq$seq.num]) + + rownames(get_weird) <- colnames(input.seq$data.name$geno)[input.seq$seq.num] + get_weird <- get_weird[order(get_weird$y),] + plot(get_weird$x, get_weird$y, xlab="alternative order", ylab = "Genome position") + + inverted <- removed <- vector() + if(interactive()){ + ANSWER <- "Y" + while(substr(ANSWER, 1, 1) == "y" | substr(ANSWER, 1, 1) == "yes" | substr(ANSWER, 1, 1) == "Y" | ANSWER == ""){ + plot(get_weird$x, get_weird$y, xlab="sequence order", ylab = "Genome position") + mks.to.remove <- gatepoints::fhs(get_weird, mark = TRUE) + if(length(which(rownames(get_weird) %in% mks.to.remove)) > 0){ + ANSWER2 <- readline("Enter 'invert/remove' to proceed with the edition: ") + if(ANSWER2 == "invert"){ + inverted <- c(inverted, as.vector(mks.to.remove)) + repl <- get_weird[rev(which(rownames(get_weird) %in% as.vector(mks.to.remove))),] + get_weird[which(rownames(get_weird) %in% as.vector(mks.to.remove)),2] <- repl[,2] + } else { + removed <- c(removed, as.vector(mks.to.remove)) + get_weird <- get_weird[-which(rownames(get_weird) %in% mks.to.remove),] + } + } + ANSWER <- readline("Enter 'Y/n' to proceed with interactive edition or quit: ") + } + plot(get_weird$x, get_weird$y, xlab="sequence order", ylab = "Genome position") + } + + return(structure(list(edited_order = rownames(get_weird), + removed = removed, + inverted = inverted, + data.name = input.seq$data.name, + twopts = input.seq$twopt), class = "onemap.edit.order")) +} + diff --git a/R/make_seq.R b/R/make_seq.R index 42e5124..53debf2 100644 --- a/R/make_seq.R +++ b/R/make_seq.R @@ -110,8 +110,8 @@ make_seq <- function(input.obj, arg = NULL, phase = NULL, data.name = NULL, twopt = NULL) { # checking for correct object - if(!(inherits(input.obj, c("onemap", "rf_2pts", "group", "compare", "try", "order", "group.upgma")))) - stop(deparse(substitute(input.obj))," is not an object of class 'onemap', 'rf_2pts', 'group', 'group.upgma','compare', 'try' or 'order'") + if(!(inherits(input.obj, c("onemap", "rf_2pts", "group", "compare", "try", "order", "group.upgma", "onemap.edit.order")))) + stop(deparse(substitute(input.obj))," is not an object of class 'onemap', 'rf_2pts', 'group', 'group.upgma','compare', 'onemap.edit.order', 'try' or 'order'") if(inherits(input.obj, "onemap")){ if (length(arg) == 1 && is.character(arg)) { seq.num <- which(input.obj$CHROM == arg) @@ -204,6 +204,12 @@ make_seq <- probs <- input.obj$probs3 } twopt <- input.obj$twopt + } else if(inherits(input.obj, "onemap.edit.order")){ + seq.num <- match(input.obj$edited_order, colnames(input.obj$twopts$data.name$geno)) + seq.phases <- -1 + seq.rf <- -1 + seq.like <- NULL + twopt <- input.obj$twopts } ## check if any marker appears more than once in the sequence diff --git a/man/edit_order_onemap.Rd b/man/edit_order_onemap.Rd new file mode 100644 index 0000000..fadf060 --- /dev/null +++ b/man/edit_order_onemap.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/filters.R +\name{edit_order_onemap} +\alias{edit_order_onemap} +\title{Edit sequence ordered by reference genome positions +comparing to another set order} +\usage{ +edit_order_onemap(input.seq) +} +\arguments{ +\item{input.seq}{object of class sequence with alternative order (not genomic order)} +} +\description{ +Edit sequence ordered by reference genome positions +comparing to another set order +} +\author{ +Cristiane Taniguti, \email{chtaniguti@tamu.edu} +} diff --git a/tests/testthat/test-export_functions.R b/tests/testthat/test-export_functions.R index 7aca1fd..40dd256 100644 --- a/tests/testthat/test-export_functions.R +++ b/tests/testthat/test-export_functions.R @@ -18,4 +18,31 @@ test_that("Combine and split datasets", { viewmap.obj <- export_viewpoly(seqs.list) expect_equal(names(viewmap.obj), c("d.p1", "d.p2", "ph.p1", "ph.p2", "maps", "software")) + + genoprob_list <- lapply(seqs.list, export_mappoly_genoprob) + + expect_equal(sum(genoprob_list[[1]]$map), 66.24, tolerance = 1) + + #homoprob <- mappoly::calc_homologprob(genoprob_list) + #mappoly::plot(homoprob, lg = 2) + + # ind.names <- dimnames(genoprob_list[[1]]$probs)[[3]] + # fake.pheno <- matrix(sample(32:100, length(ind.names)*3, replace = TRUE), nrow=length(ind.names)) + # rownames(fake.pheno) <- ind.names + # colnames(fake.pheno) <- paste0("pheno", 1:3) + # + # library(qtlpoly) + # data = read_data(ploidy = 2, geno.prob = genoprob_list, pheno = fake.pheno, step = 1) # fix + # print(data, detailed = TRUE) + # + # remim.mod = remim(data = data, w.size = 15, sig.fwd = 0.01, sig.bwd = 1e-04, + # d.sint = 1.5, n.clusters = 4) + # print(remim.mod) + # + # + # data("maps4x") + # data("pheno4x") + # genoprob4x = lapply(maps4x, mappoly::calc_genoprob) + # data = read_data(ploidy = 4, geno.prob = genoprob4x, pheno = pheno4x, step = 1) + }) diff --git a/tests/testthat/test-filters.R b/tests/testthat/test-filters.R index 2065812..73a010a 100644 --- a/tests/testthat/test-filters.R +++ b/tests/testthat/test-filters.R @@ -29,9 +29,6 @@ test_that("number of bins",{ check_bins("vcf_example_bc", 25) check_bins("vcf_example_riself",25) - # Check add bins - - # Test add bins data("vcf_example_out") bins <- find_bins(vcf_example_out) @@ -39,11 +36,20 @@ test_that("number of bins",{ twopts <- rf_2pts(onemap_bins) lgs <- group(make_seq(twopts, "all")) + lg1 <- make_seq(lgs,1) + + # Test edit_order_onemap - interactive + # input.obj <- edit_order_onemap(input.seq = lg1) + # seq_edit <- make_seq(input.obj) + map1 <- map(lg1) map2 <- map(make_seq(lgs,4)) + # Test plot_genome_vs_cm p <- plot_genome_vs_cm(map.list = map1, group.names = "LG2") + + # Test summary_maps_onemap df <- summary_maps_onemap(map.list = list(map1, map2)) expect_equal(df$map_length[3], 159.7943, 0.1) @@ -54,6 +60,7 @@ test_that("number of bins",{ expect_equal(ord1$seq.num, 1:23) expect_equal(ord2$seq.num, 15:23) + # Test add_redundants map_red <- add_redundants(sequence = map1, onemap.obj = vcf_example_out, bins) From 71f3dcda6599a59b32f186716e113264d46f8348 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Fri, 30 Jun 2023 10:16:42 -0500 Subject: [PATCH 21/36] fix #64 --- DESCRIPTION | 7 +++++-- NEWS.md | 11 ++++++++++- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6d7568e..815d367 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: onemap Title: Construction of Genetic Maps in Experimental Crosses -Version: 3.0.0 +Version: 3.0.1 Description: Analysis of molecular marker data from model (backcrosses, F2 and recombinant inbred lines) and non-model systems (i. e. outcrossing species). For the later, it allows statistical @@ -25,6 +25,9 @@ Authors@R: c(person("Gabriel", person("Rodrigo", "Amadeu", role = "ctb"), + person("Jeekin", + "Lau", + role = "ctb"), person("Karl", "Broman", role = "ctb"), @@ -42,7 +45,7 @@ Authors@R: c(person("Gabriel", email = "augusto.garcia@usp.br")) Author: Gabriel Margarido [aut], Marcelo Mollinari [aut], Cristiane Taniguti [ctb, cre], Getulio Ferreira [ctb], - Rodrigo Amadeu [ctb], Karl Broman [ctb], + Rodrigo Amadeu [ctb], Jeekin Lau [ctb], Karl Broman [ctb], Katharine Preedy [ctb, cph] (MDS ordering algorithm), Bastian Schiffthaler [ctb, cph] (HMM parallelization), Augusto Garcia [aut, ctb] diff --git a/NEWS.md b/NEWS.md index ace72df..8f3a52e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -171,4 +171,13 @@ Taniguti, C. H., Taniguti, L. M., Amadeu, R. R., Mollinari, M., Da, G., Pereira, * New function to save RAM memory after filters: keep_only_selected_mks * Review spell_check * Avoid -Inf likelihood result by increasing the tolerance value -* Fix bug in mds_onemap \ No newline at end of file +* Fix bug in mds_onemap + +# onemap 3.0.1 + +* New plot for cM x Mb relation (plot_genome_vs_cm) +* New function to export to VIEWpoly (export_viewpoly) +* New function to order markers by chromosome position (ord_by_geno) +* New function to create map summary (summary_maps_onemap) - based on MAPpoly function +* New function to interactive edition of ordering (edit_order_onemap) +* New function to export haplotype probabilities to QTLpoly (export_mappoly_genoprob) From 13f8a7d1b51ae4d675d32166c9fd5abc32ce68f2 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Fri, 30 Jun 2023 15:12:07 -0500 Subject: [PATCH 22/36] fix #78 --- R/create_dataset_bins.R | 5 ++- R/filters.R | 5 ++- R/onemap_read_vcfR.R | 67 +++++++++++++++++++++++++++----- R/plot_genome_vs_cm.R | 1 + R/return_geno.R | 53 +++++++++++++++---------- R/write_haplotypes.R | 27 ++++++++----- README.md | 2 +- man/parents_haplotypes.Rd | 11 +++++- tests/testthat/test-haplotypes.R | 41 ++++++++++++++++--- 9 files changed, 160 insertions(+), 52 deletions(-) diff --git a/R/create_dataset_bins.R b/R/create_dataset_bins.R index f5df7f0..f7f0ed3 100644 --- a/R/create_dataset_bins.R +++ b/R/create_dataset_bins.R @@ -79,8 +79,9 @@ create_data_bins <- function(input.obj, bins) #dat.temp$phase<-input.obj$phase[wrk] dat.temp$n.phe<-input.obj$n.phe dat.temp$pheno<-input.obj$pheno - dat.temp$CHROM <- input.obj$CHROM[wrk] - dat.temp$POS <- input.obj$POS[wrk] + if(!is.null(input.obj$CHROM)) dat.temp$CHROM <- input.obj$CHROM[wrk] + if(!is.null(input.obj$POS)) dat.temp$POS <- input.obj$POS[wrk] + if(!is.null(input.obj$ref_alt_alleles)) dat.temp$ref_alt_alleles <- input.obj$ref_alt_alleles[wrk,] dat.temp$error <- input.obj$error[wrk + rep(c(0:(input.obj$n.ind-1))*input.obj$n.mar, each=length(wrk)),] return(dat.temp) } diff --git a/R/filters.R b/R/filters.R index ba202a8..e651488 100644 --- a/R/filters.R +++ b/R/filters.R @@ -62,8 +62,9 @@ filter_missing <- function(onemap.obj=NULL, threshold= 0.25, by = "markers", ver new.onemap.obj$n.mar <- length(idx) new.onemap.obj$segr.type <- onemap.obj$segr.type[idx] new.onemap.obj$segr.type.num <- onemap.obj$segr.type.num[idx] - new.onemap.obj$CHROM <- onemap.obj$CHROM[idx] - new.onemap.obj$POS <- onemap.obj$POS[idx] + if(!is.null(onemap.obj$CHROM)) new.onemap.obj$CHROM <- onemap.obj$CHROM[idx] + if(!is.null(onemap.obj$POS)) new.onemap.obj$POS <- onemap.obj$POS[idx] + if(!is.null(onemap.obj$ref_alt_alleles)) new.onemap.obj$ref_alt_alleles <- onemap.obj$ref_alt_alleles[idx,] new.onemap.obj$error <- onemap.obj$error[idx + rep(c(0:(onemap.obj$n.ind-1))*onemap.obj$n.mar, each=length(idx)),] if(verbose) cat("Number of markers removed from the onemap object: ", length(which(perc.mis > threshold)), "\n") } else if (by == "individuals"){ diff --git a/R/onemap_read_vcfR.R b/R/onemap_read_vcfR.R index d647bdc..1096756 100644 --- a/R/onemap_read_vcfR.R +++ b/R/onemap_read_vcfR.R @@ -195,6 +195,9 @@ onemap_read_vcfR <- function(vcf=NULL, } n.mk <- nrow(GT_matrix) + alleles <- strsplit(ALT, ",") + for(i in 1:length(alleles)) alleles[[i]] <- c(REF[i],alleles[[i]]) + mk.type <- mk.type.num <- rep(NA, n.mk) if (cross == "outcross"){ P1_1 <- sapply(strsplit(GT_matrix[,P1], "/"), "[", 1) @@ -202,6 +205,13 @@ onemap_read_vcfR <- function(vcf=NULL, P2_1 <- sapply(strsplit(GT_matrix[,P2], "/"), "[", 1) P2_2 <- sapply(strsplit(GT_matrix[,P2], "/"), "[", 2) + P1_1_allele <- unlist(Map("[",alleles,as.numeric(P1_1) + 1)) + P1_2_allele <- unlist(Map("[",alleles,as.numeric(P1_2) + 1)) + P2_1_allele <- unlist(Map("[",alleles,as.numeric(P2_1) + 1)) + P2_2_allele <- unlist(Map("[",alleles,as.numeric(P2_2) + 1)) + + names(P1_1_allele) <- names(P1_2_allele) <- names(P2_1_allele) <- names(P2_2_allele) <- rownames(GT_matrix) + # Marker types GT_parents <- cbind(P1_1, P1_2,P2_1, P2_2) idx <- which(P1_1 == "." | P2_1 == "." | P1_2 == "." | P2_2 == ".") @@ -289,23 +299,23 @@ onemap_read_vcfR <- function(vcf=NULL, GT_matrix[idx,][which(GT_matrix[idx,] == cat | GT_matrix[idx,] == cat.rev)] <- 4 idx <- which(mk.type=="B3.7") - cat <- paste0(P1_1[idx], "/", P2_1[idx]) # 18 - cat.rev <- paste0(P2_1[idx], "/", P1_1[idx]) # 18 + cat <- paste0(P1_1[idx], "/", P2_1[idx]) + cat.rev <- paste0(P2_1[idx], "/", P1_1[idx]) GT_matrix[idx,][which(GT_matrix[idx,] == cat | GT_matrix[idx,] == cat.rev)] <- 1 - cat <- paste0(P1_1[idx], "/", P2_2[idx]) # 18 - cat.rev <- paste0(P2_2[idx], "/", P1_1[idx]) # 18 + cat <- paste0(P1_1[idx], "/", P2_2[idx]) + cat.rev <- paste0(P2_2[idx], "/", P1_1[idx]) GT_matrix[idx,][which(GT_matrix[idx,] == cat | GT_matrix[idx,] == cat.rev)] <- 2 - cat <- paste0(P1_2[idx], "/", P2_2[idx]) # 18 - cat.rev <- paste0(P2_2[idx], "/", P1_2[idx]) # 18 + cat <- paste0(P1_2[idx], "/", P2_2[idx]) + cat.rev <- paste0(P2_2[idx], "/", P1_2[idx]) GT_matrix[idx,][which(GT_matrix[idx,] == cat | GT_matrix[idx,] == cat.rev)] <- 3 idx <- which(mk.type=="D1.10") idx.sub <- which(P1_1[idx] == P2_1[idx]) - cat <- paste0(P1_1[idx][idx.sub], "/", P2_1[idx][idx.sub]) # 6 - cat.rev <- paste0(P2_1[idx][idx.sub], "/", P1_1[idx][idx.sub]) # 6 + cat <- paste0(P1_1[idx][idx.sub], "/", P2_1[idx][idx.sub]) + cat.rev <- paste0(P2_1[idx][idx.sub], "/", P1_1[idx][idx.sub]) GT_matrix[idx[idx.sub],][which(GT_matrix[idx[idx.sub],] == cat | GT_matrix[idx[idx.sub],] == cat.rev)] <- 1 - cat <- paste0(P1_2[idx][idx.sub], "/", P2_1[idx][idx.sub]) # 6 - cat.rev <- paste0(P2_1[idx][idx.sub], "/", P1_2[idx][idx.sub]) # 6 + cat <- paste0(P1_2[idx][idx.sub], "/", P2_1[idx][idx.sub]) + cat.rev <- paste0(P2_1[idx][idx.sub], "/", P1_2[idx][idx.sub]) GT_matrix[idx[idx.sub],][which(GT_matrix[idx[idx.sub],] == cat | GT_matrix[idx[idx.sub],] == cat.rev)] <- 2 idx.sub <- which(P1_2[idx] == P2_1[idx]) @@ -358,6 +368,16 @@ onemap_read_vcfR <- function(vcf=NULL, mk.type[which(GT_matrix[,P1] == "1/1" & GT_matrix[,P2] == "0/0")] <- "A.H.B.2" GT_parents <- GT_matrix[,c(P1,P2)] + P1_1_allele <- GT_parents[,1] + P1_1_allele[which(GT_parents[,1] == "0/0")] <- REF[which(GT_parents[,1] == "0/0")] + P1_1_allele[which(GT_parents[,1] == "1/1")] <- ALT[which(GT_parents[,1] == "1/1")] + P2_1_allele <- P1_1_allele + + P2_2_allele <- GT_parents[,2] + P2_2_allele[which(GT_parents[,2] == "0/0")] <- REF[which(GT_parents[,2] == "0/0")] + P2_2_allele[which(GT_parents[,2] == "1/1")] <- ALT[which(GT_parents[,2] == "1/1")] + P1_2_allele <- P2_2_allele + # Informs to user why markers are being removed idx <- which(GT_matrix[,P1] == "./." | GT_matrix[,P2] == "./.") if(verbose){ @@ -420,6 +440,16 @@ onemap_read_vcfR <- function(vcf=NULL, mk.type[which(GT_matrix[,P1] == "1/1" & GT_matrix[,P2] == "0/0")] <- "A.H.2" GT_parents <- GT_matrix[,c(P1,P2)] + P1_1_allele <- GT_parents[,1] + P1_1_allele[which(GT_parents[,1] == "0/0")] <- REF[which(GT_parents[,1] == "0/0")] + P1_1_allele[which(GT_parents[,1] == "1/1")] <- ALT[which(GT_parents[,1] == "1/1")] + P2_1_allele <- P1_1_allele + + P2_2_allele <- GT_parents[,2] + P2_2_allele[which(GT_parents[,2] == "0/0")] <- REF[which(GT_parents[,2] == "0/0")] + P2_2_allele[which(GT_parents[,2] == "1/1")] <- ALT[which(GT_parents[,2] == "1/1")] + P1_2_allele <- P2_2_allele + # Informs to user why markers are being removed if(verbose) { idx <- which(GT_matrix[,P1] == "./." | GT_matrix[,P2] == "./.") @@ -483,6 +513,17 @@ onemap_read_vcfR <- function(vcf=NULL, mk.type[which(GT_matrix[,P1] == "1/1" & GT_matrix[,P2] == "0/0")] <- "A.B.2" GT_parents <- GT_matrix[,c(P1,P2)] + P1_1_allele <- GT_parents[,1] + P1_2_allele <- GT_parents[,1] + P1_1_allele[which(GT_parents[,1] == "0/0")] <- REF[which(GT_parents[,1] == "0/0")] + P1_1_allele[which(GT_parents[,1] == "1/1")] <- ALT[which(GT_parents[,1] == "1/1")] + P1_2_allele <- P1_1_allele + P2_1_allele <- GT_parents[,2] + P2_2_allele <- GT_parents[,2] + P2_1_allele[which(GT_parents[,2] == "0/0")] <- REF[which(GT_parents[,2] == "0/0")] + P2_1_allele[which(GT_parents[,2] == "1/1")] <- ALT[which(GT_parents[,2] == "1/1")] + P2_2_allele <- P2_1_allele + # Informs to user why markers are being removed if(verbose) { idx <- which(GT_matrix[,P1] == "./." | GT_matrix[,P2] == "./.") @@ -569,6 +610,11 @@ onemap_read_vcfR <- function(vcf=NULL, } rownames(GT_matrix) <- MKS + ref_alt_alleles <- data.frame(P1_1_allele = P1_1_allele[match(MKS, names(P1_1_allele))], # smaller number in the VCF codification Ex: 0 if 0/1; 2 if 2/4 + P1_2_allele = P1_2_allele[match(MKS, names(P1_2_allele))], # larger number in the VCF codification Ex: 1 if 0/1; 4 if 2/4 + P2_1_allele = P2_1_allele[match(MKS, names(P2_1_allele))], + P2_2_allele = P2_2_allele[match(MKS, names(P2_2_allele))]) + legacy_crosses <- setNames(c("outcross", "f2", "backcross", "riself", "risib"), c("outcross", "f2 intercross", "f2 backcross", "ri self", "ri sib")) @@ -581,6 +627,7 @@ onemap_read_vcfR <- function(vcf=NULL, pheno = NULL, CHROM = CHROM, POS = POS, + ref_alt_alleles = ref_alt_alleles, input = "vcf"), class=c("onemap",legacy_crosses[cross])) diff --git a/R/plot_genome_vs_cm.R b/R/plot_genome_vs_cm.R index 202c9cb..f110c0d 100644 --- a/R/plot_genome_vs_cm.R +++ b/R/plot_genome_vs_cm.R @@ -36,6 +36,7 @@ plot_genome_vs_cm = function(map.list,mapping_function="kosambi", group.names=NU ## if map.list is just a single chormosome, convert it into a list if(inherits(map.list,"sequence")) map.list<-list(map.list) + if(map.list[[1]]$seq.rf == -1) stop("The genetic distances were not estimated for this sequence yet") if(is.null(map.list[[1]]$data.name$POS) | is.null(map.list[[1]]$data.name$CHROM)) stop("Reference genome chromosome and position informaion is not available in the dataset.") diff --git a/R/return_geno.R b/R/return_geno.R index 69b6453..3fd0a5f 100644 --- a/R/return_geno.R +++ b/R/return_geno.R @@ -22,7 +22,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","b","d","c")), '-1.1' = return(c("b","a","c","d")), '-1.-1' = return(c("b","a","d","c")) - ) + ) }, 'A.2' = { switch(EXPR=link.phases, @@ -30,7 +30,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","b","c","a")), '-1.1' = return(c("b","a","a","c")), '-1.-1' = return(c("b","a","c","a")) - ) + ) }, 'A.3' = { switch(EXPR=link.phases, @@ -38,7 +38,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","b","o","c")), '-1.1' = return(c("b","a","c","o")), '-1.-1' = return(c("b","a","o","c")) - ) + ) }, 'A.4' = { switch(EXPR=link.phases, @@ -46,7 +46,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","o","o","b")), '-1.1' = return(c("o","a","b","o")), '-1.-1' = return(c("o","a","o","b")) - ) + ) }, 'B1.5' = { switch(EXPR=link.phases, @@ -54,7 +54,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","b","o","a")), '-1.1' = return(c("b","a","a","o")), '-1.-1' = return(c("b","a","o","a")) - ) + ) }, 'B2.6' = { switch(EXPR=link.phases, @@ -62,7 +62,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","o","b","a")), '-1.1' = return(c("o","a","a","b")), '-1.-1' = return(c("o","a","b","a")) - ) + ) }, 'B3.7' = { switch(EXPR=link.phases, @@ -70,7 +70,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","b","b","a")), '-1.1' = return(c("b","a","a","b")), '-1.-1' = return(c("b","a","b","a")) - ) + ) }, 'C.8' = { switch(EXPR=link.phases, @@ -78,7 +78,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","o","o","a")), '-1.1' = return(c("o","a","a","o")), '-1.-1' = return(c("o","a","o","a")) - ) + ) }, 'D1.9' = { switch(EXPR=link.phases, @@ -86,7 +86,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","b","c","c")), '-1.1' = return(c("b","a","c","c")), '-1.-1' = return(c("b","a","c","c")) - ) + ) }, 'D1.10' = { switch(EXPR=link.phases, @@ -94,7 +94,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","b","a","a")), '-1.1' = return(c("b","a","a","a")), '-1.-1' = return(c("b","a","a","a")) - ) + ) }, 'D1.11' = { switch(EXPR=link.phases, @@ -102,7 +102,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","b","o","o")), '-1.1' = return(c("b","a","o","o")), '-1.-1' = return(c("b","a","o","o")) - ) + ) }, 'D1.12' = { switch(EXPR=link.phases, @@ -110,7 +110,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("b","o","a","a")), '-1.1' = return(c("o","b","a","a")), '-1.-1' = return(c("o","b","a","a")) - ) + ) }, 'D1.13' = { switch(EXPR=link.phases, @@ -118,7 +118,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","o","o","o")), '-1.1' = return(c("o","a","o","o")), '-1.-1' = return(c("o","a","o","o")) - ) + ) }, 'D2.14' = { switch(EXPR=link.phases, @@ -126,7 +126,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("c","c","b","a")), '-1.1' = return(c("c","c","a","b")), '-1.-1' = return(c("c","c","b","a")) - ) + ) }, 'D2.15' = { switch(EXPR=link.phases, @@ -134,7 +134,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","a","b","a")), '-1.1' = return(c("a","a","a","b")), '-1.-1' = return(c("a","a","b","a")) - ) + ) }, 'D2.16' = { switch(EXPR=link.phases, @@ -142,7 +142,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("o","o","b","a")), '-1.1' = return(c("o","o","a","b")), '-1.-1' = return(c("o","o","b","a")) - ) + ) }, 'D2.17' = { switch(EXPR=link.phases, @@ -150,7 +150,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("a","a","o","b")), '-1.1' = return(c("a","a","b","o")), '-1.-1' = return(c("a","a","o","b")) - ) + ) }, 'D2.18' = { switch(EXPR=link.phases, @@ -158,7 +158,7 @@ return_geno <- function(segr.type, link.phases) { '1.-1' = return(c("o","o","o","a")), '-1.1' = return(c("o","o","a","o")), '-1.-1' = return(c("o","o","o","a")) - ) + ) }, 'C.A' = { switch(EXPR=link.phases, @@ -184,7 +184,20 @@ return_geno <- function(segr.type, link.phases) { '-1.-1' = return(c("b","a","b","a")) ) } - ) + ) } -# end of file \ No newline at end of file + +return_geno_ref_alt <- function(link.phases, ref_alt) { + out <- switch(EXPR=link.phases, + '1.1' = ref_alt, + '1.-1' = ref_alt[c(1,2,4,3)], + '-1.1' = ref_alt[c(2,1,3,4)], + '-1.-1' = ref_alt[c(2,1,4,3)] + ) + + out <- unlist(out) + names(out) <- NULL + + return(out) +} diff --git a/R/write_haplotypes.R b/R/write_haplotypes.R index 03b5121..df435c6 100644 --- a/R/write_haplotypes.R +++ b/R/write_haplotypes.R @@ -24,6 +24,8 @@ globalVariables(c("V1", "V2", "V3", "V4", #' #' @param ... objects of class sequence #' @param group_names vector of characters defining the group names +#' @param map.function "kosambi" or "haldane" according to which was used to build the map +#' @param ref_alt_alleles TRUE to return parents haplotypes as reference and alternative ref_alt_alleles codification #' #' @return data.frame with group ID (group), marker number (mk.number) #' and names (mk.names), position in centimorgan (dist) and parents haplotypes @@ -40,19 +42,19 @@ globalVariables(c("V1", "V2", "V3", "V4", #' @author Getulio Caixeta Ferreira, \email{getulio.caifer@@gmail.com} #' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} #' @export -parents_haplotypes <- function(..., group_names=NULL){ - input <- list(...) - if(length(input) == 0) stop("argument '...' missing, with no default") +parents_haplotypes <- function(..., group_names=NULL, map.function = "kosambi", ref_alt_alleles = FALSE){ + input_raw <- list(...) + if(length(input_raw) == 0) stop("argument '...' missing, with no default") # Accept list of sequences or list of list of sequences - if(inherits(input[[1]], "sequence")) input.map <- input else input.map <- unlist(input, recursive = FALSE) + if(inherits(input_raw[[1]], "sequence")) input.map <- input_raw else input.map <- unlist(input_raw, recursive = FALSE) if(!all(sapply(input.map, function(x) inherits(x, "sequence")))) stop(paste("Input objects must be of 'sequence' class. \n")) if(is.null(group_names)) group_names <- paste("Group",seq(input.map), sep = " - ") - if(all(sapply(input, function(x) inherits(x, "sequence")))){ - n <- length(sapply(input, function(x) inherits(x, "sequence"))) + if(all(sapply(input_raw, function(x) inherits(x, "sequence")))){ + n <- length(sapply(input_raw, function(x) inherits(x, "sequence"))) } else n <- 1 - input_temp <- input + input_temp <- input_raw out_dat <- data.frame() for(z in 1:n){ if(all(sapply(input_temp, function(x) inherits(x, "sequence")))) input <- input_temp[[z]] @@ -75,14 +77,18 @@ parents_haplotypes <- function(..., group_names=NULL){ ## display results marnumbers <- input$seq.num - distances <- c(0,cumsum(get(get(".map.fun", envir=.onemapEnv))(input$seq.rf))) + distances <- if(map.function == "kosambi") c(0,cumsum(kosambi(input$seq.rf))) else if(map.function == "haldane") c(0,cumsum(haldane(input$seq.rf))) ## whith diplotypes for class 'outcross' if(inherits(input$data.name, c("outcross", "f2"))){ ## create diplotypes from segregation types and linkage phases link.phases <- apply(link.phases,1,function(x) paste(as.character(x),collapse=".")) parents <- matrix("",length(input$seq.num),4) for (i in 1:length(input$seq.num)) - parents[i,] <- return_geno(input$data.name$segr.type[input$seq.num[i]],link.phases[i]) + if(!is.null(input$data.name$ref_alt_alleles) & ref_alt_alleles){ + # Changing by reference and alternative alleles + parents[i,] <- return_geno_ref_alt(link.phases = link.phases[i], + ref_alt = input$data.name$ref_alt_alleles[input$seq.num[i],]) + } else parents[i,] <- return_geno(segr.type = input$data.name$segr.type[input$seq.num[i]], link.phases = link.phases[i]) out_dat_temp <- data.frame(group= group_names[z], mk.number = marnumbers, mk.names = marnames, dist = as.numeric(distances), P1_1 = parents[,1], P1_2 = parents[,2], @@ -96,6 +102,7 @@ parents_haplotypes <- function(..., group_names=NULL){ } else warning("invalid cross type") } } + return(out_dat) } @@ -427,7 +434,7 @@ plot.onemap_progeny_haplotypes_counts <- function(x, n.graphics =NULL, ncol=NULL, ...){ if(!inherits(x, "onemap_progeny_haplotypes_counts")) stop("Input need is not of class onemap_progeny_haplotyes_counts") - + p <- list() n.ind <- length(unique(x$ind)) nb.cols <- n.ind diff --git a/README.md b/README.md index 29294a1..d12d383 100644 --- a/README.md +++ b/README.md @@ -112,7 +112,7 @@ Margarido, G. R. A., Souza, A. P., &38; Garcia, A. A. F. (2007). OneMap: softwar * If you are using OneMap versions > 2.0, please cite also: -Taniguti, C. H., Taniguti, L. M., Amadeu, R. R., Mollinari, M., Da, G., Pereira, S., Riera-Lizarazu, O., Lau, J., Byrne, D., de Siqueira Gesteira, G., De, T., Oliveira, P., Ferreira, G. C., &; Franco Garcia, A. A. Developing best practices for genotyping-by-sequencing analysis using linkage maps as benchmarks. BioRxiv. https://doi.org/10.1101/2022.11.24.517847 +[Taniguti, C. H.; Taniguti, L. M.; Amadeu, R. R.; Lau, J.; de Siqueira Gesteira, G.; Oliveira, T. de P.; Ferreira, G. C.; Pereira, G. da S.; Byrne, D.; Mollinari, M.; Riera-Lizarazu, O.; Garcia, A. A. F. Developing best practices for genotyping-by-sequencing analysis using linkage maps as benchmarks. BioRxiv. https://doi.org/10.1101/2022.11.24.517847](https://www.biorxiv.org/content/10.1101/2022.11.24.517847v3) * If you used the HMM parallelization, please cite [BatchMap](https://github.com/bschiffthaler/BatchMap) paper too: diff --git a/man/parents_haplotypes.Rd b/man/parents_haplotypes.Rd index f679983..46e6d0a 100644 --- a/man/parents_haplotypes.Rd +++ b/man/parents_haplotypes.Rd @@ -4,12 +4,21 @@ \alias{parents_haplotypes} \title{Generates data.frame with parents estimated haplotypes} \usage{ -parents_haplotypes(..., group_names = NULL) +parents_haplotypes( + ..., + group_names = NULL, + map.function = "kosambi", + ref_alt_alleles = FALSE +) } \arguments{ \item{...}{objects of class sequence} \item{group_names}{vector of characters defining the group names} + +\item{map.function}{"kosambi" or "haldane" according to which was used to build the map} + +\item{ref_alt_alleles}{TRUE to return parents haplotypes as reference and alternative ref_alt_alleles codification} } \value{ data.frame with group ID (group), marker number (mk.number) diff --git a/tests/testthat/test-haplotypes.R b/tests/testthat/test-haplotypes.R index 7c49ed5..0b701c7 100644 --- a/tests/testthat/test-haplotypes.R +++ b/tests/testthat/test-haplotypes.R @@ -1,9 +1,8 @@ context("test plot haplotypes") test_that("ordering and HMM parallel", { - test_haplo <- function(example_data, which.group, sum.counts){ - eval(bquote(data(.(example_data)))) - onemap_mis <- eval(bquote(filter_missing(get(.(example_data)), 0.15))) + test_haplo <- function(example_data, which.group, sum.counts, parent_haplo = NULL, parent_haplo_ref_alt = NULL){ + onemap_mis <- eval(bquote(filter_missing(.(example_data), 0.15))) twopt <- rf_2pts(onemap_mis) all_mark <- make_seq(twopt,"all") lod_sug <- suggest_lod(all_mark) @@ -12,11 +11,41 @@ test_that("ordering and HMM parallel", { map1 <- onemap::map(LG) dist <- cumsum(kosambi(map1$seq.rf)) expect_equal(dist[length(dist)], 100, tolerance = 5) # The simulated distance of Chr01 is 100 + if(!inherits(onemap_mis, "backcross") & !inherits(onemap_mis, "ri")){ + haplo_default <- parents_haplotypes(map1) + to_match <- unlist(haplo_default[3, 5:8]) + names(to_match) <- NULL + eval(bquote(expect_equal(to_match, .(parent_haplo)))) + if(!is.null(onemap_mis$ref_alt_alleles)){ + haplo_ref_alt <- parents_haplotypes(map1, ref_alt_alleles = TRUE) + to_match <- unlist(haplo_ref_alt[3, 5:8]) + names(to_match) <- NULL + eval(bquote(expect_equal(to_match, .(parent_haplo_ref_alt)))) + } + } counts <- progeny_haplotypes_counts(x = progeny_haplotypes(map1, most_likely = T, ind = "all")) eval(bquote(expect_equal(sum(counts$counts), .(sum.counts)))) } - test_haplo("simu_example_bc", 1, 126) - test_haplo("simu_example_out", 1, 347) - test_haplo("simu_example_f2", 1, 216) + data("simu_example_bc") + test_haplo(example_data = simu_example_bc, 1, 126) + data("simu_example_out") + test_haplo(example_data = simu_example_out, 1, 347, parent_haplo = c("a", "a", "b", "a")) + data("simu_example_f2") + test_haplo(example_data = simu_example_f2, 1, 216, parent_haplo = c("a", "b", "a", "b")) + + example_data <- onemap_read_vcfR(vcf = system.file("extdata/simu_cod_out.vcf.gz", package = "onemap"), + parent1 = "P2", + parent2 = "P1", + cross = "outcross", only_biallelic = FALSE) + + test_haplo(example_data, which.group = 1, sum.counts = 336, c("c", "c", "a", "b"), c("C", "C", "A", "G")) + + example_data <- onemap_read_vcfR(vcf = system.file("extdata/simu_cod_f2.vcf.gz", package = "onemap"), + parent1 = "P1", + parent2 = "P2", + cross = "f2 intercross", only_biallelic = FALSE) + + test_haplo(example_data, which.group = 1, sum.counts = 201, c("a", "b", "a", "b"), c("T", "A", "T", "A")) + }) From bf7f7b8e8a7cde57ef3064718f9de92efc962d19 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Fri, 30 Jun 2023 15:15:35 -0500 Subject: [PATCH 23/36] update version --- DESCRIPTION | 2 +- NEWS.md | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 815d367..d2f59d9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: onemap Title: Construction of Genetic Maps in Experimental Crosses -Version: 3.0.1 +Version: 3.1.0 Description: Analysis of molecular marker data from model (backcrosses, F2 and recombinant inbred lines) and non-model systems (i. e. outcrossing species). For the later, it allows statistical diff --git a/NEWS.md b/NEWS.md index 8f3a52e..301d197 100644 --- a/NEWS.md +++ b/NEWS.md @@ -173,7 +173,7 @@ Taniguti, C. H., Taniguti, L. M., Amadeu, R. R., Mollinari, M., Da, G., Pereira, * Avoid -Inf likelihood result by increasing the tolerance value * Fix bug in mds_onemap -# onemap 3.0.1 +# onemap 3.1.0 * New plot for cM x Mb relation (plot_genome_vs_cm) * New function to export to VIEWpoly (export_viewpoly) @@ -181,3 +181,5 @@ Taniguti, C. H., Taniguti, L. M., Amadeu, R. R., Mollinari, M., Da, G., Pereira, * New function to create map summary (summary_maps_onemap) - based on MAPpoly function * New function to interactive edition of ordering (edit_order_onemap) * New function to export haplotype probabilities to QTLpoly (export_mappoly_genoprob) +* Keep reference and alternative alleles information from imported VCF +* Return parents haplotypes using reference and alternative alleles codification when outcross or f2 cross type From 699f539f9cf306d5a1d89f5643737f772f6a8e48 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Fri, 30 Jun 2023 16:15:13 -0500 Subject: [PATCH 24/36] fix #80 --- NAMESPACE | 2 ++ NEWS.md | 2 ++ R/export_functions.R | 59 ++++++++++++++++++++++++++++++++ R/plot_genome_vs_cm.R | 2 +- man/load_onemap_sequences.Rd | 14 ++++++++ man/save_onemap_sequences.Rd | 20 +++++++++++ tests/testthat/test-filters.R | 9 +++++ tests/testthat/test-haplotypes.R | 2 +- 8 files changed, 108 insertions(+), 2 deletions(-) create mode 100644 man/load_onemap_sequences.Rd create mode 100644 man/save_onemap_sequences.Rd diff --git a/NAMESPACE b/NAMESPACE index 1d489f8..23f58cf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -48,6 +48,7 @@ export(group_upgma) export(haldane) export(keep_only_selected_mks) export(kosambi) +export(load_onemap_sequences) export(make_seq) export(map) export(map_avoid_unlinked) @@ -73,6 +74,7 @@ export(rf_graph_table) export(rf_snp_filter_onemap) export(ripple_seq) export(rm_dupli_mks) +export(save_onemap_sequences) export(seeded_map) export(select_segreg) export(seq_by_type) diff --git a/NEWS.md b/NEWS.md index 301d197..2d16c68 100644 --- a/NEWS.md +++ b/NEWS.md @@ -183,3 +183,5 @@ Taniguti, C. H., Taniguti, L. M., Amadeu, R. R., Mollinari, M., Da, G., Pereira, * New function to export haplotype probabilities to QTLpoly (export_mappoly_genoprob) * Keep reference and alternative alleles information from imported VCF * Return parents haplotypes using reference and alternative alleles codification when outcross or f2 cross type +* Functions to export and import reduced size onemap R objects (save_onemap_sequences and load_onemap_sequences) +* Add new author (Jeekin Lau :smile: ) \ No newline at end of file diff --git a/R/export_functions.R b/R/export_functions.R index 936c166..2d2a36f 100644 --- a/R/export_functions.R +++ b/R/export_functions.R @@ -103,3 +103,62 @@ export_mappoly_genoprob <- function(input.map){ map = map), class = "mappoly.genoprob") } + +#' Save a list of onemap sequence objects +#' +#' The onemap sequence object contains everything users need to reproduce the complete analysis: +#' the input onemap object, the rf_2pts result, and the sequence genetic distance and marker order. +#' Therefore, a list of sequences is the only object users need to save to be able to recover all analysis. +#' But simple saving the list of sequences will save many redundant objects. This redundancy is only considered by R +#' when saving the object. For example, one input object and the rf_2pts result will be saved for every sequence. +#' +#'@param sequences.list list of \code{sequence} objects +#' +#'@param filename name of the output file (Ex: my_beautiful_map.RData) +#' +#'@export +save_onemap_sequences <- function(sequences.list, filename){ + if(!(inherits(sequences.list,c("list", "sequence")))) stop(deparse(substitute(sequences.list))," is not an object of class 'list' or 'sequence'") + + ## if sequences.list is just a single chormosome, convert it into a list + if(inherits(sequences.list,"sequence")) sequences.list<-list(sequences.list) + + onemap.obj <- sequences.list[[1]]$data.name + twopts <- sequences.list[[1]]$twopt + + sequences.list[[1]]$data.name <- NULL + sequences.list[[1]]$twopt <- NULL + + for(i in 2:length(sequences.list)){ + if(!all(onemap.obj$segr.type == sequences.list[[i]]$data.name$segr.type)) stop("Not all sequences come from the same onemap object.") + if(!all(twopts$n.mar == sequences.list[[i]]$twopt$n.mar)) stop("Not all sequences come from the same twopts object.") + sequences.list[[i]]$data.name <- NULL + sequences.list[[i]]$twopt <- NULL + } + + new.list<- list(onemap.obj =onemap.obj, twopts = twopts, sequences.list = sequences.list) + + save(new.list, file = filename) +} + +#' Load list of sequences saved by save_onemap_sequences +#' +#' @param filename name of the file to be loaded +#' +#'@export +load_onemap_sequences <- function(filename){ + temp <- load(filename) + map.list <- get(temp) + + if(is.null(names(map.list)) | !all(names(map.list) == c("onemap.obj", "twopts", "sequences.list"))) + stop("This file was not saved with save_onemap_sequences.") + + sequences.list <- map.list$sequences.list + for(i in 1:length(sequences.list)){ + sequences.list[[i]]$data.name <- map.list$onemap.obj + sequences.list[[i]]$twopt <- map.list$twopts + } + return(sequences.list) +} + + diff --git a/R/plot_genome_vs_cm.R b/R/plot_genome_vs_cm.R index f110c0d..3f54ee3 100644 --- a/R/plot_genome_vs_cm.R +++ b/R/plot_genome_vs_cm.R @@ -36,7 +36,7 @@ plot_genome_vs_cm = function(map.list,mapping_function="kosambi", group.names=NU ## if map.list is just a single chormosome, convert it into a list if(inherits(map.list,"sequence")) map.list<-list(map.list) - if(map.list[[1]]$seq.rf == -1) stop("The genetic distances were not estimated for this sequence yet") + if(map.list[[1]]$seq.rf[1] == -1) stop("The genetic distances were not estimated for this sequence yet") if(is.null(map.list[[1]]$data.name$POS) | is.null(map.list[[1]]$data.name$CHROM)) stop("Reference genome chromosome and position informaion is not available in the dataset.") diff --git a/man/load_onemap_sequences.Rd b/man/load_onemap_sequences.Rd new file mode 100644 index 0000000..0cf4f8e --- /dev/null +++ b/man/load_onemap_sequences.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/export_functions.R +\name{load_onemap_sequences} +\alias{load_onemap_sequences} +\title{Load list of sequences saved by save_onemap_sequences} +\usage{ +load_onemap_sequences(filename) +} +\arguments{ +\item{filename}{name of the file to be loaded} +} +\description{ +Load list of sequences saved by save_onemap_sequences +} diff --git a/man/save_onemap_sequences.Rd b/man/save_onemap_sequences.Rd new file mode 100644 index 0000000..7240acd --- /dev/null +++ b/man/save_onemap_sequences.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/export_functions.R +\name{save_onemap_sequences} +\alias{save_onemap_sequences} +\title{Save a list of onemap sequence objects} +\usage{ +save_onemap_sequences(sequences.list, filename) +} +\arguments{ +\item{sequences.list}{list of \code{sequence} objects} + +\item{filename}{name of the output file (Ex: my_beautiful_map.RData)} +} +\description{ +The onemap sequence object contains everything users need to reproduce the complete analysis: +the input onemap object, the rf_2pts result, and the sequence genetic distance and marker order. +Therefore, a list of sequences is the only object users need to save to be able to recover all analysis. +But simple saving the list of sequences will save many redundant objects. This redundancy is only considered by R +when saving the object. For example, one input object and the rf_2pts result will be saved for every sequence. +} diff --git a/tests/testthat/test-filters.R b/tests/testthat/test-filters.R index 73a010a..32f6554 100644 --- a/tests/testthat/test-filters.R +++ b/tests/testthat/test-filters.R @@ -46,6 +46,15 @@ test_that("number of bins",{ map1 <- map(lg1) map2 <- map(make_seq(lgs,4)) + # Test save sequences + maps.list <- list(map1, map2) + + save_onemap_sequences(sequences.list = maps.list, filename = "test.RData") + save(maps.list, file = "test2.RData") + + # Test load sequences + maps.list.load <- load_onemap_sequences(filename = "test.RData") + # Test plot_genome_vs_cm p <- plot_genome_vs_cm(map.list = map1, group.names = "LG2") diff --git a/tests/testthat/test-haplotypes.R b/tests/testthat/test-haplotypes.R index 0b701c7..1b10be1 100644 --- a/tests/testthat/test-haplotypes.R +++ b/tests/testthat/test-haplotypes.R @@ -46,6 +46,6 @@ test_that("ordering and HMM parallel", { parent2 = "P2", cross = "f2 intercross", only_biallelic = FALSE) - test_haplo(example_data, which.group = 1, sum.counts = 201, c("a", "b", "a", "b"), c("T", "A", "T", "A")) + test_haplo(example_data, which.group = 1, sum.counts = 306, c("a", "b", "a", "b"), c("T", "A", "T", "A")) }) From 5cc5379b323cfcf4dee74cb55e5ae1518f8b0ada Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Mon, 3 Jul 2023 10:13:01 -0500 Subject: [PATCH 25/36] more tests --- tests/testthat/test-filters.R | 43 ++++++++++++++++++++++++++---- tests/testthat/test-ordering_hmm.R | 4 +-- 2 files changed, 40 insertions(+), 7 deletions(-) diff --git a/tests/testthat/test-filters.R b/tests/testthat/test-filters.R index 32f6554..fe30ed2 100644 --- a/tests/testthat/test-filters.R +++ b/tests/testthat/test-filters.R @@ -1,5 +1,7 @@ context("Filters function") +library(vcfR) + test_that("number of distorted markers",{ check_dist <- function(example_data, table.h0){ eval(bquote(data(.(example_data)))) @@ -77,16 +79,19 @@ test_that("number of bins",{ }) test_that("number of missing data",{ - check_missing <- function(example_data, n.mar){ + check_missing <- function(example_data, n.mar,n.ind){ eval(bquote(data(.(example_data)))) onemap_mis <- eval(bquote(filter_missing(get(.(example_data)), 0.5))) eval(bquote(expect_equal(check_data(onemap_mis), 0))) eval(bquote(expect_equal(onemap_mis$n.mar, .(n.mar)))) + onemap_mis <- eval(bquote(filter_missing(get(.(example_data)), 0.5, by = "individuals"))) + eval(bquote(expect_equal(check_data(onemap_mis), 0))) + eval(bquote(expect_equal(onemap_mis$n.ind, .(n.ind)))) } - check_missing("vcf_example_f2", 25) - check_missing("onemap_example_riself", 64) - check_missing("onemap_example_out", 30) - check_missing("onemap_example_bc", 67) + check_missing(example_data = "vcf_example_f2", n.mar = 25, n.ind = 191) + check_missing("onemap_example_riself", 64, 100) + check_missing("onemap_example_out", 30, 100) + check_missing("onemap_example_bc", 67,150) }) test_that("number of repeated ID markers",{ @@ -103,3 +108,31 @@ test_that("number of repeated ID markers",{ check_dupli("onemap_example_bc", 67) }) + +test_that("filter probs",{ + onemap.obj <- onemap_read_vcfR(system.file("extdata/vcf_example_out.vcf.gz", package = "onemap"), + parent1 = "P1", parent2 = "P2", cross = "outcross") + vcfR.object <- read.vcfR(system.file("extdata/vcf_example_out.vcf.gz", package = "onemap")) + gq <- extract_depth(vcfR.object = vcfR.object, + onemap.object = onemap.obj, + vcf.par = "GQ", + parent1 = "P1", + parent2 = "P2") + onemap.prob <- create_probs(onemap.obj, genotypes_errors = gq) + onemap.filt <- filter_prob(onemap.prob, threshold = 0.999999999) + onemap.mis <- filter_missing(onemap.filt, threshold = 0.10) + expect_equal(onemap.mis$n.mar, 22) + + pl <- extract_depth(vcfR.object = vcfR.object, + onemap.object = onemap.obj, + vcf.par = "PL", + parent1 = "P1", + parent2 = "P2") + + onemap.prob <- create_probs(onemap.obj, genotypes_probs = pl) + onemap.filt <- filter_prob(onemap.prob, threshold = 0.9) + onemap.mis <- filter_missing(onemap.filt, threshold = 0.10) + expect_equal(onemap.mis$n.mar, 22) + +}) + diff --git a/tests/testthat/test-ordering_hmm.R b/tests/testthat/test-ordering_hmm.R index a422fd0..6ecd639 100644 --- a/tests/testthat/test-ordering_hmm.R +++ b/tests/testthat/test-ordering_hmm.R @@ -30,8 +30,8 @@ test_that("ordering and HMM test", { size <- cumsum(kosambi(LG.mds$seq.rf)) eval(bquote(expect_equal(size[length(size)], .(right.size),tolerance = tol.size))) LG.order <- order_seq(LG) - LG.order <- make_seq(LG.order, "force") - eval(bquote(expect_equal(LG.order$seq.num, .(right.order), tolerance = tol.order))) # mds makes local rearrangements + LG.order_force <- make_seq(LG.order, "force") + eval(bquote(expect_equal(LG.order_force$seq.num, .(right.order), tolerance = tol.order))) # mds makes local rearrangements size <- cumsum(kosambi(LG.mds$seq.rf)) eval(bquote(expect_equal(size[length(size)], .(right.size),tolerance = tol.size))) } From e3f95c3dd9382f7fba446a296fc352ac906d5060 Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Sat, 12 Aug 2023 19:34:55 -0500 Subject: [PATCH 26/36] bugfix read_mapmaker --- DESCRIPTION | 180 ++++++++++++------------- R/plot_genome_vs_cm.R | 120 ++++++++--------- R/read_mapmaker.R | 6 +- R/summary_maps.R | 124 ++++++++--------- man/plot_genome_vs_cm.Rd | 52 +++---- man/summary_maps_onemap.Rd | 48 +++---- tests/testthat/test-export_functions.R | 96 ++++++------- 7 files changed, 312 insertions(+), 314 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index d2f59d9..fbccc39 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,90 +1,90 @@ -Package: onemap -Title: Construction of Genetic Maps in Experimental Crosses -Version: 3.1.0 -Description: Analysis of molecular marker data from model (backcrosses, - F2 and recombinant inbred lines) and non-model systems (i. e. - outcrossing species). For the later, it allows statistical - analysis by simultaneously estimating linkage and linkage - phases (genetic map construction) according to Wu et al. (2002) - . All analysis are based on multipoint - approaches using hidden Markov models. -Authors@R: c(person("Gabriel", - "Margarido", - role = "aut", - email = "gramarga@usp.br"), - person("Marcelo", - "Mollinari", - role = "aut"), - person("Cristiane", - "Taniguti", - role=c("ctb", "cre"), - email="chtaniguti@tamu.edu"), - person("Getulio", - "Ferreira", - role="ctb"), - person("Rodrigo", - "Amadeu", - role = "ctb"), - person("Jeekin", - "Lau", - role = "ctb"), - person("Karl", - "Broman", - role = "ctb"), - person(given = "Katharine", - family = "Preedy", - role = c("ctb", "cph"), - comment = "MDS ordering algorithm"), - person(given = "Bastian", - family = "Schiffthaler", - role = c("ctb","cph"), - comment = "HMM parallelization"), - person("Augusto", - "Garcia", - role = c("aut", "ctb"), - email = "augusto.garcia@usp.br")) -Author: Gabriel Margarido [aut], Marcelo Mollinari [aut], - Cristiane Taniguti [ctb, cre], Getulio Ferreira [ctb], - Rodrigo Amadeu [ctb], Jeekin Lau [ctb], Karl Broman [ctb], - Katharine Preedy [ctb, cph] (MDS ordering algorithm), - Bastian Schiffthaler [ctb, cph] (HMM parallelization), - Augusto Garcia [aut, ctb] -LinkingTo: Rcpp (>= 0.10.5) -Depends: R (>= 3.6.0) -Imports: ggplot2 (>= 2.2.1), - plotly (>= 4.7.1), - reshape2 (>= 1.4.1), - Rcpp (>= 0.10.5), - graphics, - methods, - stats, - utils, - grDevices, - smacof, - princurve, - parallel, - dplyr, - tidyr, - htmlwidgets, - ggpubr, - RColorBrewer, - dendextend, - rebus, - vcfR (>= 1.6.0) -Suggests: - knitr (>= 1.10), - rmarkdown, - testthat, - stringr -VignetteBuilder: knitr -Encoding: UTF-8 -License: GPL-3 -URL: https://github.com/augusto-garcia/onemap -BugReports: https://github.com/augusto-garcia/onemap/wiki -Maintainer: Cristiane Taniguti -Repository: CRAN -Packaged: 2019-09-22 22:25:43 UTC; cris -NeedsCompilation: yes -Date/Publication: 2019-09-22 22:48:07 UTC -RoxygenNote: 7.2.3 -biocViews: +Package: onemap +Title: Construction of Genetic Maps in Experimental Crosses +Version: 3.1.0 +Description: Analysis of molecular marker data from model (backcrosses, + F2 and recombinant inbred lines) and non-model systems (i. e. + outcrossing species). For the later, it allows statistical + analysis by simultaneously estimating linkage and linkage + phases (genetic map construction) according to Wu et al. (2002) + . All analysis are based on multipoint + approaches using hidden Markov models. +Authors@R: c(person("Gabriel", + "Margarido", + role = "aut", + email = "gramarga@usp.br"), + person("Marcelo", + "Mollinari", + role = "aut"), + person("Cristiane", + "Taniguti", + role=c("ctb", "cre"), + email="chtaniguti@tamu.edu"), + person("Getulio", + "Ferreira", + role="ctb"), + person("Rodrigo", + "Amadeu", + role = "ctb"), + person("Jeekin", + "Lau", + role = "ctb"), + person("Karl", + "Broman", + role = "ctb"), + person(given = "Katharine", + family = "Preedy", + role = c("ctb", "cph"), + comment = "MDS ordering algorithm"), + person(given = "Bastian", + family = "Schiffthaler", + role = c("ctb","cph"), + comment = "HMM parallelization"), + person("Augusto", + "Garcia", + role = c("aut", "ctb"), + email = "augusto.garcia@usp.br")) +Author: Gabriel Margarido [aut], Marcelo Mollinari [aut], + Cristiane Taniguti [ctb, cre], Getulio Ferreira [ctb], + Rodrigo Amadeu [ctb], Jeekin Lau [ctb], Karl Broman [ctb], + Katharine Preedy [ctb, cph] (MDS ordering algorithm), + Bastian Schiffthaler [ctb, cph] (HMM parallelization), + Augusto Garcia [aut, ctb] +LinkingTo: Rcpp (>= 0.10.5) +Depends: R (>= 3.6.0) +Imports: ggplot2 (>= 2.2.1), + plotly (>= 4.7.1), + reshape2 (>= 1.4.1), + Rcpp (>= 0.10.5), + graphics, + methods, + stats, + utils, + grDevices, + smacof, + princurve, + parallel, + dplyr, + tidyr, + htmlwidgets, + ggpubr, + RColorBrewer, + dendextend, + rebus, + vcfR (>= 1.6.0) +Suggests: + knitr (>= 1.10), + rmarkdown, + testthat, + stringr +VignetteBuilder: knitr +Encoding: UTF-8 +License: GPL-3 +URL: https://github.com/augusto-garcia/onemap +BugReports: https://github.com/augusto-garcia/onemap/wiki +Maintainer: Cristiane Taniguti +Repository: CRAN +Packaged: 2019-09-22 22:25:43 UTC; cris +NeedsCompilation: yes +Date/Publication: 2019-09-22 22:48:07 UTC +RoxygenNote: 7.2.3 +biocViews: diff --git a/R/plot_genome_vs_cm.R b/R/plot_genome_vs_cm.R index 3f54ee3..82cdd0f 100644 --- a/R/plot_genome_vs_cm.R +++ b/R/plot_genome_vs_cm.R @@ -1,61 +1,61 @@ -####################################################################### -# # -# Package: onemap # -# # -# File: plot_genome_vs_cm.R # -# Contains: plot_genome_vs_cm # -# # -# Written by Jeekin Lau with minor # -# modifications by Cristiane Taniguti # -# copyright (c) 2023, Jeekin Lau # -# # -# First version: 04/24/2023 # -# License: GNU General Public License version 2 (June, 1991) or later # -# # -####################################################################### -##' Draws a physical vs cM map -##' -##' Provides simple genetic to physical ggplot. -##' @param map.list a map, i.e. an object of class \code{sequence} with a -##' predefined order, linkage phases, recombination fraction and likelihood; -##' also it could be a list of maps. -##' -##' @param mapping_function either "kosambi" or "haldane" -##' -##' @param group.names vector with group name for each sequence object in the map.list -##' -##' @return ggplot with cM on x-axis and physical position on y-axis -##' -##' @author Jeekin Lau, \email{jeekinlau@@gmail.com} -##' -##' @export plot_genome_vs_cm -##' -##' @import ggplot2 ggpubr -plot_genome_vs_cm = function(map.list,mapping_function="kosambi", group.names=NULL){ - if(!(inherits(map.list,c("list", "sequence")))) stop(deparse(substitute(map.list))," is not an object of class 'list' or 'sequence'") - - ## if map.list is just a single chormosome, convert it into a list - if(inherits(map.list,"sequence")) map.list<-list(map.list) - if(map.list[[1]]$seq.rf[1] == -1) stop("The genetic distances were not estimated for this sequence yet") - - if(is.null(map.list[[1]]$data.name$POS) | is.null(map.list[[1]]$data.name$CHROM)) stop("Reference genome chromosome and position informaion is not available in the dataset.") - - - number_chromomes = length(map.list) - plot=list() - for (i in 1:number_chromomes){ - data_for_plot = data.frame(Marker = map.list[[i]]$seq.num, - Chrom=map.list[[i]]$data.name$CHROM[map.list[[i]]$seq.num], - Position = map.list[[i]]$data.name$POS[map.list[[i]]$seq.num], - cM = {if(mapping_function=="kosambi") { - cM =cumsum(c(0,kosambi(map.list[[i]]$seq.rf))) - } else { - cM=cumsum(c(0,haldane(map.list[[i]]$seq.rf))) - }}) - plot[[i]]=ggplot(data_for_plot,mapping=aes(cM,Position))+geom_point()+ ylab("Genomic position") + - {if(!is.null(group.names)) ggtitle(paste0(group.names[i]))} + theme_bw() - } - - a=ggarrange(plotlist=plot) - return(a) +####################################################################### +# # +# Package: onemap # +# # +# File: plot_genome_vs_cm.R # +# Contains: plot_genome_vs_cm # +# # +# Written by Jeekin Lau with minor # +# modifications by Cristiane Taniguti # +# copyright (c) 2023, Jeekin Lau # +# # +# First version: 04/24/2023 # +# License: GNU General Public License version 2 (June, 1991) or later # +# # +####################################################################### +##' Draws a physical vs cM map +##' +##' Provides simple genetic to physical ggplot. +##' @param map.list a map, i.e. an object of class \code{sequence} with a +##' predefined order, linkage phases, recombination fraction and likelihood; +##' also it could be a list of maps. +##' +##' @param mapping_function either "kosambi" or "haldane" +##' +##' @param group.names vector with group name for each sequence object in the map.list +##' +##' @return ggplot with cM on x-axis and physical position on y-axis +##' +##' @author Jeekin Lau, \email{jeekinlau@@gmail.com} +##' +##' @export plot_genome_vs_cm +##' +##' @import ggplot2 ggpubr +plot_genome_vs_cm = function(map.list,mapping_function="kosambi", group.names=NULL){ + if(!(inherits(map.list,c("list", "sequence")))) stop(deparse(substitute(map.list))," is not an object of class 'list' or 'sequence'") + + ## if map.list is just a single chormosome, convert it into a list + if(inherits(map.list,"sequence")) map.list<-list(map.list) + if(map.list[[1]]$seq.rf[1] == -1) stop("The genetic distances were not estimated for this sequence yet") + + if(is.null(map.list[[1]]$data.name$POS) | is.null(map.list[[1]]$data.name$CHROM)) stop("Reference genome chromosome and position informaion is not available in the dataset.") + + + number_chromomes = length(map.list) + plot=list() + for (i in 1:number_chromomes){ + data_for_plot = data.frame(Marker = map.list[[i]]$seq.num, + Chrom=map.list[[i]]$data.name$CHROM[map.list[[i]]$seq.num], + Position = map.list[[i]]$data.name$POS[map.list[[i]]$seq.num], + cM = {if(mapping_function=="kosambi") { + cM =cumsum(c(0,kosambi(map.list[[i]]$seq.rf))) + } else { + cM=cumsum(c(0,haldane(map.list[[i]]$seq.rf))) + }}) + plot[[i]]=ggplot(data_for_plot,mapping=aes(cM,Position))+geom_point()+ ylab("Genomic position") + + {if(!is.null(group.names)) ggtitle(paste0(group.names[i]))} + theme_bw() + } + + a=ggarrange(plotlist=plot) + return(a) } \ No newline at end of file diff --git a/R/read_mapmaker.R b/R/read_mapmaker.R index c828fd2..b898b1e 100644 --- a/R/read_mapmaker.R +++ b/R/read_mapmaker.R @@ -15,8 +15,6 @@ ## # ######################################################################### -globalVariables(c("mkt.wrg")) - ## Function to read data in MAPMAKER style from input file @@ -265,8 +263,8 @@ read_mapmaker<-function (file=NULL, dir=NULL, verbose=TRUE) { if(any(is.na(match(na.omit(unique(geno[,i])), 1:5)))) { - mkt.wrg.names <- paste(sQuote(colnames(geno)[mkt.wrg]), collapse = ", ") - msg <- sprintf(ngettext(length(mkt.wrg), + mkt.wrg.names <- paste(sQuote(colnames(geno)[i]), collapse = ", ") + msg <- sprintf(ngettext(length(mkt.wrg.names), "marker %s has invalid codification", "markers %s have invalid codification"), mkt.wrg.names) stop(msg) diff --git a/R/summary_maps.R b/R/summary_maps.R index fcf78f1..3ee0c88 100644 --- a/R/summary_maps.R +++ b/R/summary_maps.R @@ -1,63 +1,63 @@ -####################################################################### -# # -# Package: onemap # -# # -# File: summary_maps.R # -# Contains: summary_maps_onemap # -# # -# Written by Jeekin Lau with minor modifications # -# from Cristiane Taniguti # -# copyright (c) 2023, Jeekin Lau # -# # -# First version: 04/24/2023 # -# License: GNU General Public License version 2 (June, 1991) or later # -# # -####################################################################### - - -##' Create table with summary information about the linkage map -##' -##' @param map.list a map, i.e. an object of class \code{sequence} with a -##' predefined order, linkage phases, recombination fraction and likelihood; -##' also it could be a list of maps. -##' -##' @param mapping_function either "kosambi" or "haldane" -##' -##' @return data.frame with basic summary statistics -##' -##' @author Jeekin Lau, \email{jeekinlau@@gmail.com} -##' -##' @import tidyr -##' -##' @export summary_maps_onemap -##' -summary_maps_onemap = function(map.list, mapping_function="kosambi"){ - - if(!(inherits(map.list,c("list", "sequence")))) stop(deparse(substitute(map.list))," is not an object of class 'list' or 'sequence'") - - ## if map.list is just a single chromosome, convert it into a list - if(inherits(map.list,"sequence")) map.list<-list(map.list) - - mk_types <- lapply(map.list, function(x) as.data.frame(table(x$data.name$segr.type[x$seq.num]))) - for(i in 1:length(mk_types)) mk_types[[i]] <- cbind(Var2=i, mk_types[[i]]) - - mk_types <- do.call(rbind, mk_types) - mk_types <- pivot_wider(mk_types, names_from = "Var1", values_from = "Freq") - mk_types[is.na(mk_types)] <- 0 - - summary=data.frame(LG = 1:length(map.list), - n_mks = unlist(lapply(map.list, function(x) length(x$seq.num))), - mk_types[,-1], - map_length = unlist(lapply(map.list, function(x) sum(c(0,kosambi(x$seq.rf))))), - max_gap = {if(mapping_function=="kosambi") { - unlist(lapply(map.list, function(x) kosambi(max(x$seq.rf)))) - } else unlist(lapply(map.list, function(x) haldane(max(x$seq.rf)))) - }) - - last_line= apply(summary, 2, sum) - - stats=rbind(summary,last_line) - stats[dim(stats)[1],1] <- "Total" - - return(stats) +####################################################################### +# # +# Package: onemap # +# # +# File: summary_maps.R # +# Contains: summary_maps_onemap # +# # +# Written by Jeekin Lau with minor modifications # +# from Cristiane Taniguti # +# copyright (c) 2023, Jeekin Lau # +# # +# First version: 04/24/2023 # +# License: GNU General Public License version 2 (June, 1991) or later # +# # +####################################################################### + + +##' Create table with summary information about the linkage map +##' +##' @param map.list a map, i.e. an object of class \code{sequence} with a +##' predefined order, linkage phases, recombination fraction and likelihood; +##' also it could be a list of maps. +##' +##' @param mapping_function either "kosambi" or "haldane" +##' +##' @return data.frame with basic summary statistics +##' +##' @author Jeekin Lau, \email{jeekinlau@@gmail.com} +##' +##' @import tidyr +##' +##' @export summary_maps_onemap +##' +summary_maps_onemap = function(map.list, mapping_function="kosambi"){ + + if(!(inherits(map.list,c("list", "sequence")))) stop(deparse(substitute(map.list))," is not an object of class 'list' or 'sequence'") + + ## if map.list is just a single chromosome, convert it into a list + if(inherits(map.list,"sequence")) map.list<-list(map.list) + + mk_types <- lapply(map.list, function(x) as.data.frame(table(x$data.name$segr.type[x$seq.num]))) + for(i in 1:length(mk_types)) mk_types[[i]] <- cbind(Var2=i, mk_types[[i]]) + + mk_types <- do.call(rbind, mk_types) + mk_types <- pivot_wider(mk_types, names_from = "Var1", values_from = "Freq") + mk_types[is.na(mk_types)] <- 0 + + summary=data.frame(LG = 1:length(map.list), + n_mks = unlist(lapply(map.list, function(x) length(x$seq.num))), + mk_types[,-1], + map_length = unlist(lapply(map.list, function(x) sum(c(0,kosambi(x$seq.rf))))), + max_gap = {if(mapping_function=="kosambi") { + unlist(lapply(map.list, function(x) kosambi(max(x$seq.rf)))) + } else unlist(lapply(map.list, function(x) haldane(max(x$seq.rf)))) + }) + + last_line= apply(summary, 2, sum) + + stats=rbind(summary,last_line) + stats[dim(stats)[1],1] <- "Total" + + return(stats) } \ No newline at end of file diff --git a/man/plot_genome_vs_cm.Rd b/man/plot_genome_vs_cm.Rd index bd5d9ec..340a18b 100644 --- a/man/plot_genome_vs_cm.Rd +++ b/man/plot_genome_vs_cm.Rd @@ -1,26 +1,26 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot_genome_vs_cm.R -\name{plot_genome_vs_cm} -\alias{plot_genome_vs_cm} -\title{Draws a physical vs cM map} -\usage{ -plot_genome_vs_cm(map.list, mapping_function = "kosambi", group.names = NULL) -} -\arguments{ -\item{map.list}{a map, i.e. an object of class \code{sequence} with a -predefined order, linkage phases, recombination fraction and likelihood; -also it could be a list of maps.} - -\item{mapping_function}{either "kosambi" or "haldane"} - -\item{group.names}{vector with group name for each sequence object in the map.list} -} -\value{ -ggplot with cM on x-axis and physical position on y-axis -} -\description{ -Provides simple genetic to physical ggplot. -} -\author{ -Jeekin Lau, \email{jeekinlau@gmail.com} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot_genome_vs_cm.R +\name{plot_genome_vs_cm} +\alias{plot_genome_vs_cm} +\title{Draws a physical vs cM map} +\usage{ +plot_genome_vs_cm(map.list, mapping_function = "kosambi", group.names = NULL) +} +\arguments{ +\item{map.list}{a map, i.e. an object of class \code{sequence} with a +predefined order, linkage phases, recombination fraction and likelihood; +also it could be a list of maps.} + +\item{mapping_function}{either "kosambi" or "haldane"} + +\item{group.names}{vector with group name for each sequence object in the map.list} +} +\value{ +ggplot with cM on x-axis and physical position on y-axis +} +\description{ +Provides simple genetic to physical ggplot. +} +\author{ +Jeekin Lau, \email{jeekinlau@gmail.com} +} diff --git a/man/summary_maps_onemap.Rd b/man/summary_maps_onemap.Rd index b472ebf..78c4c34 100644 --- a/man/summary_maps_onemap.Rd +++ b/man/summary_maps_onemap.Rd @@ -1,24 +1,24 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/summary_maps.R -\name{summary_maps_onemap} -\alias{summary_maps_onemap} -\title{Create table with summary information about the linkage map} -\usage{ -summary_maps_onemap(map.list, mapping_function = "kosambi") -} -\arguments{ -\item{map.list}{a map, i.e. an object of class \code{sequence} with a -predefined order, linkage phases, recombination fraction and likelihood; -also it could be a list of maps.} - -\item{mapping_function}{either "kosambi" or "haldane"} -} -\value{ -data.frame with basic summary statistics -} -\description{ -Create table with summary information about the linkage map -} -\author{ -Jeekin Lau, \email{jeekinlau@gmail.com} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary_maps.R +\name{summary_maps_onemap} +\alias{summary_maps_onemap} +\title{Create table with summary information about the linkage map} +\usage{ +summary_maps_onemap(map.list, mapping_function = "kosambi") +} +\arguments{ +\item{map.list}{a map, i.e. an object of class \code{sequence} with a +predefined order, linkage phases, recombination fraction and likelihood; +also it could be a list of maps.} + +\item{mapping_function}{either "kosambi" or "haldane"} +} +\value{ +data.frame with basic summary statistics +} +\description{ +Create table with summary information about the linkage map +} +\author{ +Jeekin Lau, \email{jeekinlau@gmail.com} +} diff --git a/tests/testthat/test-export_functions.R b/tests/testthat/test-export_functions.R index 40dd256..b121073 100644 --- a/tests/testthat/test-export_functions.R +++ b/tests/testthat/test-export_functions.R @@ -1,48 +1,48 @@ -context("Export functions") - -test_that("Combine and split datasets", { - - data("vcf_example_out") - - twopts <- rf_2pts(vcf_example_out) - - seq_all <- make_seq(twopts, "all") - lgs <- group(seq_all) - lg1 <- map(make_seq(lgs,1)) - lg2 <- map(make_seq(lgs,2)) - lg3 <- map(make_seq(lgs,3)) - lg4 <- map(make_seq(lgs,4)) - - seqs.list <- list(lg1, lg2, lg3, lg4) - - viewmap.obj <- export_viewpoly(seqs.list) - - expect_equal(names(viewmap.obj), c("d.p1", "d.p2", "ph.p1", "ph.p2", "maps", "software")) - - genoprob_list <- lapply(seqs.list, export_mappoly_genoprob) - - expect_equal(sum(genoprob_list[[1]]$map), 66.24, tolerance = 1) - - #homoprob <- mappoly::calc_homologprob(genoprob_list) - #mappoly::plot(homoprob, lg = 2) - - # ind.names <- dimnames(genoprob_list[[1]]$probs)[[3]] - # fake.pheno <- matrix(sample(32:100, length(ind.names)*3, replace = TRUE), nrow=length(ind.names)) - # rownames(fake.pheno) <- ind.names - # colnames(fake.pheno) <- paste0("pheno", 1:3) - # - # library(qtlpoly) - # data = read_data(ploidy = 2, geno.prob = genoprob_list, pheno = fake.pheno, step = 1) # fix - # print(data, detailed = TRUE) - # - # remim.mod = remim(data = data, w.size = 15, sig.fwd = 0.01, sig.bwd = 1e-04, - # d.sint = 1.5, n.clusters = 4) - # print(remim.mod) - # - # - # data("maps4x") - # data("pheno4x") - # genoprob4x = lapply(maps4x, mappoly::calc_genoprob) - # data = read_data(ploidy = 4, geno.prob = genoprob4x, pheno = pheno4x, step = 1) - -}) +context("Export functions") + +test_that("Combine and split datasets", { + + data("vcf_example_out") + + twopts <- rf_2pts(vcf_example_out) + + seq_all <- make_seq(twopts, "all") + lgs <- group(seq_all) + lg1 <- map(make_seq(lgs,1)) + lg2 <- map(make_seq(lgs,2)) + lg3 <- map(make_seq(lgs,3)) + lg4 <- map(make_seq(lgs,4)) + + seqs.list <- list(lg1, lg2, lg3, lg4) + + viewmap.obj <- export_viewpoly(seqs.list) + + expect_equal(names(viewmap.obj), c("d.p1", "d.p2", "ph.p1", "ph.p2", "maps", "software")) + + genoprob_list <- lapply(seqs.list, export_mappoly_genoprob) + + expect_equal(sum(genoprob_list[[1]]$map), 66.24, tolerance = 1) + + #homoprob <- mappoly::calc_homologprob(genoprob_list) + #mappoly::plot(homoprob, lg = 2) + + # ind.names <- dimnames(genoprob_list[[1]]$probs)[[3]] + # fake.pheno <- matrix(sample(32:100, length(ind.names)*3, replace = TRUE), nrow=length(ind.names)) + # rownames(fake.pheno) <- ind.names + # colnames(fake.pheno) <- paste0("pheno", 1:3) + # + # library(qtlpoly) + # data = read_data(ploidy = 2, geno.prob = genoprob_list, pheno = fake.pheno, step = 1) # fix + # print(data, detailed = TRUE) + # + # remim.mod = remim(data = data, w.size = 15, sig.fwd = 0.01, sig.bwd = 1e-04, + # d.sint = 1.5, n.clusters = 4) + # print(remim.mod) + # + # + # data("maps4x") + # data("pheno4x") + # genoprob4x = lapply(maps4x, mappoly::calc_genoprob) + # data = read_data(ploidy = 4, geno.prob = genoprob4x, pheno = pheno4x, step = 1) + +}) From 6cbe886ca30da9f448d55e6e49721da662449dc1 Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Mon, 28 Aug 2023 17:01:18 -0500 Subject: [PATCH 27/36] fix order edition --- R/filters.R | 377 +++++++-------- R/write_haplotypes.R | 1042 +++++++++++++++++++++--------------------- 2 files changed, 711 insertions(+), 708 deletions(-) diff --git a/R/filters.R b/R/filters.R index e651488..6977f7f 100644 --- a/R/filters.R +++ b/R/filters.R @@ -1,188 +1,189 @@ -####################################################################### -## ## -## Package: onemap ## -## ## -## File: filters.R ## -## Contains: filter_missing filter_prob edit_order ## -## ## -## Written by Cristiane Taniguti ## -## copyright (c) 2007-9, Cristiane Taniguti ## -## ## -## First version: 22/11/2019 ## -## License: GNU General Public License version 2 (June, 1991) or later ## -## ## -####################################################################### - -## Function filter markers by missing data - -##' Filter markers according with a missing data threshold -##' -##' @param onemap.obj an object of class \code{onemap}. -##' @param threshold a numeric from 0 to 1 to define the threshold of missing data allowed -##' @param by character defining if `markers` or `individuals` should be filtered -##' @param verbose A logical, if TRUE it output progress status -##' information. -##' -##' @return An object of class \code{onemap}, i.e., a list with the following -##' components: \item{geno}{a matrix with integers indicating the genotypes -##' read for each marker. Each column contains data for a marker and each row -##' represents an individual.} \item{n.ind}{number of individuals.} -##' \item{n.mar}{number of markers.} \item{segr.type}{a vector with the -##' segregation type of each marker, as \code{strings}.} \item{segr.type.num}{a -##' vector with the segregation type of each marker, represented in a -##' simplified manner as integers, i.e. 1 corresponds to markers of type -##' \code{"A"}; 2 corresponds to markers of type \code{"B1.5"}; 3 corresponds -##' to markers of type \code{"B2.6"}; 4 corresponds to markers of type -##' \code{"B3.7"}; 5 corresponds to markers of type \code{"C.8"}; 6 corresponds -##' to markers of type \code{"D1"} and 7 corresponds to markers of type -##' \code{"D2"}. Markers for F2 intercrosses are coded as 1; all other crosses -##' are left as \code{NA}.} \item{input}{the name of the input file.} -##' \item{n.phe}{number of phenotypes.} \item{pheno}{a matrix with phenotypic -##' values. Each column contains data for a trait and each row represents an -##' individual.} \item{error}{matrix containing HMM emission probabilities} -##' -##' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} -##' @examples -##' -##' data(onemap_example_out) -##' filt_obj <- filter_missing(onemap_example_out, threshold=0.25) -##' -##'@export -filter_missing <- function(onemap.obj=NULL, threshold= 0.25, by = "markers", verbose = TRUE){ - if(!inherits(onemap.obj,"onemap")){ - stop("onemap.obj should be of class onemap\n") - } - - if(by == "markers"){ - perc.mis <- apply(onemap.obj$geno, 2, function(x) sum(x == 0)/length(x)) - idx <- which(!perc.mis > threshold) - - new.onemap.obj <- onemap.obj - new.onemap.obj$geno <- onemap.obj$geno[,idx] - new.onemap.obj$n.mar <- length(idx) - new.onemap.obj$segr.type <- onemap.obj$segr.type[idx] - new.onemap.obj$segr.type.num <- onemap.obj$segr.type.num[idx] - if(!is.null(onemap.obj$CHROM)) new.onemap.obj$CHROM <- onemap.obj$CHROM[idx] - if(!is.null(onemap.obj$POS)) new.onemap.obj$POS <- onemap.obj$POS[idx] - if(!is.null(onemap.obj$ref_alt_alleles)) new.onemap.obj$ref_alt_alleles <- onemap.obj$ref_alt_alleles[idx,] - new.onemap.obj$error <- onemap.obj$error[idx + rep(c(0:(onemap.obj$n.ind-1))*onemap.obj$n.mar, each=length(idx)),] - if(verbose) cat("Number of markers removed from the onemap object: ", length(which(perc.mis > threshold)), "\n") - } else if (by == "individuals"){ - perc.mis <- apply(onemap.obj$geno, 1, function(x) sum(x == 0)/length(x)) - idx <- which(!perc.mis > threshold) - new.onemap.obj <- onemap.obj - new.onemap.obj$geno <- onemap.obj$geno[idx,] - new.onemap.obj$n.ind <- length(idx) - new.onemap.obj$error <- onemap.obj$error[1:onemap.obj$n.mar + rep((idx-1)*onemap.obj$n.mar, each=onemap.obj$n.mar),] - if(verbose) cat("Number of indiduals removed from the onemap object: ", length(which(perc.mis > threshold)), "\n") - } else { - stop("Input for argument by is not defined. Please choose between `markers` or `individuals` options.") - } - return(new.onemap.obj) -} - - -##' Function filter genotypes by genotype probability -##' -##' @param onemap.obj an object of class \code{onemap}. -##' @param threshold a numeric from 0 to 1 to define the threshold for -##' the probability of the called genotype (highest probability) -##' @param verbose If \code{TRUE}, print tracing information. -##' -##' @return An object of class \code{onemap}, i.e., a list with the following -##' components: \item{geno}{a matrix with integers indicating the genotypes -##' read for each marker. Each column contains data for a marker and each row -##' represents an individual.} \item{n.ind}{number of individuals.} -##' \item{n.mar}{number of markers.} \item{segr.type}{a vector with the -##' segregation type of each marker, as \code{strings}.} \item{segr.type.num}{a -##' vector with the segregation type of each marker, represented in a -##' simplified manner as integers, i.e. 1 corresponds to markers of type -##' \code{"A"}; 2 corresponds to markers of type \code{"B1.5"}; 3 corresponds -##' to markers of type \code{"B2.6"}; 4 corresponds to markers of type -##' \code{"B3.7"}; 5 corresponds to markers of type \code{"C.8"}; 6 corresponds -##' to markers of type \code{"D1"} and 7 corresponds to markers of type -##' \code{"D2"}. Markers for F2 intercrosses are coded as 1; all other crosses -##' are left as \code{NA}.} \item{input}{the name of the input file.} -##' \item{n.phe}{number of phenotypes.} \item{pheno}{a matrix with phenotypic -##' values. Each column contains data for a trait and each row represents an -##' individual.} \item{error}{matrix containing HMM emission probabilities} -##' -##' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} -##' @examples -##' \donttest{ -##' data(onemap_example_out) -##' filt_obj <- filter_prob(onemap_example_out, threshold=0.8) -##' } -##' @importFrom reshape2 melt dcast -##' -##' @export -filter_prob <- function(onemap.obj=NULL, threshold= 0.8, verbose=TRUE){ - idx <- apply(onemap.obj$error, 1, which.max) - rm <- which(onemap.obj$error[cbind(seq_along(idx), idx)] < threshold) - onemap.obj$error[rm,] <- 1 - if(verbose) cat(paste(length(rm), "genotypes were converted to missing data.")) - - geno_melt <- melt(onemap.obj$geno) - geno_melt[rm,3] <- 0 - geno <- dcast(geno_melt, Var1 ~ Var2) - rownames(geno) <- geno$Var1 - geno <- geno[,-1] - - onemap.obj$geno <- as.matrix(geno) - - return(onemap.obj) -} - - -#' Edit sequence ordered by reference genome positions -#' comparing to another set order -#' -#' @param input.seq object of class sequence with alternative order (not genomic order) -#' -#' @author Cristiane Taniguti, \email{chtaniguti@tamu.edu} -#' -#' @export -edit_order_onemap <- function(input.seq){ - - if (!inherits(input.seq, "sequence")) { - stop(deparse(substitute(input.seq)), " is not an object of class 'sequence'") - } - - if(unique(input.seq$data.name$CHROM[input.seq$seq.num]) > 1) stop("There are markers from more than one chromosome in the sequence.") - - get_weird <- data.frame(x = 1:length(input.seq$seq.num), - y = input.seq$data.name$POS[input.seq$seq.num]) - - rownames(get_weird) <- colnames(input.seq$data.name$geno)[input.seq$seq.num] - get_weird <- get_weird[order(get_weird$y),] - plot(get_weird$x, get_weird$y, xlab="alternative order", ylab = "Genome position") - - inverted <- removed <- vector() - if(interactive()){ - ANSWER <- "Y" - while(substr(ANSWER, 1, 1) == "y" | substr(ANSWER, 1, 1) == "yes" | substr(ANSWER, 1, 1) == "Y" | ANSWER == ""){ - plot(get_weird$x, get_weird$y, xlab="sequence order", ylab = "Genome position") - mks.to.remove <- gatepoints::fhs(get_weird, mark = TRUE) - if(length(which(rownames(get_weird) %in% mks.to.remove)) > 0){ - ANSWER2 <- readline("Enter 'invert/remove' to proceed with the edition: ") - if(ANSWER2 == "invert"){ - inverted <- c(inverted, as.vector(mks.to.remove)) - repl <- get_weird[rev(which(rownames(get_weird) %in% as.vector(mks.to.remove))),] - get_weird[which(rownames(get_weird) %in% as.vector(mks.to.remove)),2] <- repl[,2] - } else { - removed <- c(removed, as.vector(mks.to.remove)) - get_weird <- get_weird[-which(rownames(get_weird) %in% mks.to.remove),] - } - } - ANSWER <- readline("Enter 'Y/n' to proceed with interactive edition or quit: ") - } - plot(get_weird$x, get_weird$y, xlab="sequence order", ylab = "Genome position") - } - - return(structure(list(edited_order = rownames(get_weird), - removed = removed, - inverted = inverted, - data.name = input.seq$data.name, - twopts = input.seq$twopt), class = "onemap.edit.order")) -} - +####################################################################### +## ## +## Package: onemap ## +## ## +## File: filters.R ## +## Contains: filter_missing filter_prob edit_order ## +## ## +## Written by Cristiane Taniguti ## +## copyright (c) 2007-9, Cristiane Taniguti ## +## ## +## First version: 22/11/2019 ## +## License: GNU General Public License version 2 (June, 1991) or later ## +## ## +####################################################################### + +## Function filter markers by missing data + +##' Filter markers according with a missing data threshold +##' +##' @param onemap.obj an object of class \code{onemap}. +##' @param threshold a numeric from 0 to 1 to define the threshold of missing data allowed +##' @param by character defining if `markers` or `individuals` should be filtered +##' @param verbose A logical, if TRUE it output progress status +##' information. +##' +##' @return An object of class \code{onemap}, i.e., a list with the following +##' components: \item{geno}{a matrix with integers indicating the genotypes +##' read for each marker. Each column contains data for a marker and each row +##' represents an individual.} \item{n.ind}{number of individuals.} +##' \item{n.mar}{number of markers.} \item{segr.type}{a vector with the +##' segregation type of each marker, as \code{strings}.} \item{segr.type.num}{a +##' vector with the segregation type of each marker, represented in a +##' simplified manner as integers, i.e. 1 corresponds to markers of type +##' \code{"A"}; 2 corresponds to markers of type \code{"B1.5"}; 3 corresponds +##' to markers of type \code{"B2.6"}; 4 corresponds to markers of type +##' \code{"B3.7"}; 5 corresponds to markers of type \code{"C.8"}; 6 corresponds +##' to markers of type \code{"D1"} and 7 corresponds to markers of type +##' \code{"D2"}. Markers for F2 intercrosses are coded as 1; all other crosses +##' are left as \code{NA}.} \item{input}{the name of the input file.} +##' \item{n.phe}{number of phenotypes.} \item{pheno}{a matrix with phenotypic +##' values. Each column contains data for a trait and each row represents an +##' individual.} \item{error}{matrix containing HMM emission probabilities} +##' +##' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} +##' @examples +##' +##' data(onemap_example_out) +##' filt_obj <- filter_missing(onemap_example_out, threshold=0.25) +##' +##'@export +filter_missing <- function(onemap.obj=NULL, threshold= 0.25, by = "markers", verbose = TRUE){ + if(!inherits(onemap.obj,"onemap")){ + stop("onemap.obj should be of class onemap\n") + } + + if(by == "markers"){ + perc.mis <- apply(onemap.obj$geno, 2, function(x) sum(x == 0)/length(x)) + idx <- which(!perc.mis > threshold) + + new.onemap.obj <- onemap.obj + new.onemap.obj$geno <- onemap.obj$geno[,idx] + new.onemap.obj$n.mar <- length(idx) + new.onemap.obj$segr.type <- onemap.obj$segr.type[idx] + new.onemap.obj$segr.type.num <- onemap.obj$segr.type.num[idx] + if(!is.null(onemap.obj$CHROM)) new.onemap.obj$CHROM <- onemap.obj$CHROM[idx] + if(!is.null(onemap.obj$POS)) new.onemap.obj$POS <- onemap.obj$POS[idx] + if(!is.null(onemap.obj$ref_alt_alleles)) new.onemap.obj$ref_alt_alleles <- onemap.obj$ref_alt_alleles[idx,] + new.onemap.obj$error <- onemap.obj$error[idx + rep(c(0:(onemap.obj$n.ind-1))*onemap.obj$n.mar, each=length(idx)),] + if(verbose) cat("Number of markers removed from the onemap object: ", length(which(perc.mis > threshold)), "\n") + } else if (by == "individuals"){ + perc.mis <- apply(onemap.obj$geno, 1, function(x) sum(x == 0)/length(x)) + idx <- which(!perc.mis > threshold) + new.onemap.obj <- onemap.obj + new.onemap.obj$geno <- onemap.obj$geno[idx,] + new.onemap.obj$n.ind <- length(idx) + new.onemap.obj$error <- onemap.obj$error[1:onemap.obj$n.mar + rep((idx-1)*onemap.obj$n.mar, each=onemap.obj$n.mar),] + if(verbose) cat("Number of indiduals removed from the onemap object: ", length(which(perc.mis > threshold)), "\n") + } else { + stop("Input for argument by is not defined. Please choose between `markers` or `individuals` options.") + } + return(new.onemap.obj) +} + + +##' Function filter genotypes by genotype probability +##' +##' @param onemap.obj an object of class \code{onemap}. +##' @param threshold a numeric from 0 to 1 to define the threshold for +##' the probability of the called genotype (highest probability) +##' @param verbose If \code{TRUE}, print tracing information. +##' +##' @return An object of class \code{onemap}, i.e., a list with the following +##' components: \item{geno}{a matrix with integers indicating the genotypes +##' read for each marker. Each column contains data for a marker and each row +##' represents an individual.} \item{n.ind}{number of individuals.} +##' \item{n.mar}{number of markers.} \item{segr.type}{a vector with the +##' segregation type of each marker, as \code{strings}.} \item{segr.type.num}{a +##' vector with the segregation type of each marker, represented in a +##' simplified manner as integers, i.e. 1 corresponds to markers of type +##' \code{"A"}; 2 corresponds to markers of type \code{"B1.5"}; 3 corresponds +##' to markers of type \code{"B2.6"}; 4 corresponds to markers of type +##' \code{"B3.7"}; 5 corresponds to markers of type \code{"C.8"}; 6 corresponds +##' to markers of type \code{"D1"} and 7 corresponds to markers of type +##' \code{"D2"}. Markers for F2 intercrosses are coded as 1; all other crosses +##' are left as \code{NA}.} \item{input}{the name of the input file.} +##' \item{n.phe}{number of phenotypes.} \item{pheno}{a matrix with phenotypic +##' values. Each column contains data for a trait and each row represents an +##' individual.} \item{error}{matrix containing HMM emission probabilities} +##' +##' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} +##' @examples +##' \donttest{ +##' data(onemap_example_out) +##' filt_obj <- filter_prob(onemap_example_out, threshold=0.8) +##' } +##' @importFrom reshape2 melt dcast +##' +##' @export +filter_prob <- function(onemap.obj=NULL, threshold= 0.8, verbose=TRUE){ + idx <- apply(onemap.obj$error, 1, which.max) + rm <- which(onemap.obj$error[cbind(seq_along(idx), idx)] < threshold) + onemap.obj$error[rm,] <- 1 + if(verbose) cat(paste(length(rm), "genotypes were converted to missing data.")) + + geno_melt <- melt(onemap.obj$geno) + geno_melt[rm,3] <- 0 + geno <- dcast(geno_melt, Var1 ~ Var2) + rownames(geno) <- geno$Var1 + geno <- geno[,-1] + + onemap.obj$geno <- as.matrix(geno) + + return(onemap.obj) +} + + +#' Edit sequence ordered by reference genome positions +#' comparing to another set order +#' +#' @param input.seq object of class sequence with alternative order (not genomic order) +#' +#' @author Cristiane Taniguti, \email{chtaniguti@tamu.edu} +#' +#' @export +edit_order_onemap <- function(input.seq){ + + if (!inherits(input.seq, "sequence")) { + stop(deparse(substitute(input.seq)), " is not an object of class 'sequence'") + } + + if(length(unique(input.seq$data.name$CHROM[input.seq$seq.num])) > 1) stop("There are markers from more than one chromosome in the sequence.") + + get_weird <- data.frame(x = 1:length(input.seq$seq.num), + y = input.seq$data.name$POS[input.seq$seq.num]) + + rownames(get_weird) <- colnames(input.seq$data.name$geno)[input.seq$seq.num] + get_weird <- get_weird[order(get_weird$y),] + plot(get_weird$x, get_weird$y, xlab="alternative order", ylab = "Genome position") + + inverted <- removed <- vector() + if(interactive()){ + ANSWER <- "Y" + while(substr(ANSWER, 1, 1) == "y" | substr(ANSWER, 1, 1) == "yes" | substr(ANSWER, 1, 1) == "Y" | ANSWER == ""){ + plot(get_weird$x, get_weird$y, xlab="sequence order", ylab = "Genome position") + mks.to.remove <- gatepoints::fhs(get_weird, mark = TRUE) + if(length(which(rownames(get_weird) %in% mks.to.remove)) > 0){ + ANSWER2 <- readline("Enter 'invert/remove' to proceed with the edition: ") + if(ANSWER2 == "invert"){ + inverted <- c(inverted, as.vector(mks.to.remove)) + repl <- get_weird[rev(which(rownames(get_weird) %in% as.vector(mks.to.remove))),] + get_weird[which(rownames(get_weird) %in% as.vector(mks.to.remove)),2] <- repl[,2] + rownames(get_weird)[which(rownames(get_weird) %in% as.vector(mks.to.remove))] <- rownames(repl) + } else { + removed <- c(removed, as.vector(mks.to.remove)) + get_weird <- get_weird[-which(rownames(get_weird) %in% mks.to.remove),] + } + } + ANSWER <- readline("Enter 'Y/n' to proceed with interactive edition or quit: ") + } + plot(get_weird$x, get_weird$y, xlab="sequence order", ylab = "Genome position") + } + + return(structure(list(edited_order = rownames(get_weird), + removed = removed, + inverted = inverted, + data.name = input.seq$data.name, + twopts = input.seq$twopt), class = "onemap.edit.order")) +} + diff --git a/R/write_haplotypes.R b/R/write_haplotypes.R index df435c6..1890939 100644 --- a/R/write_haplotypes.R +++ b/R/write_haplotypes.R @@ -1,520 +1,522 @@ -####################################################################### -## ## -## Package: onemap ## -## ## -## File: write_haplotypes.R ## -## Contains: parents_haplotypes, progeny_haplotypes, ## -## plot.onemap_progeny_haplotypes, ## -## plot.onemap_progeny_haplotypes_counts ## -## ## -## Written by Getulio Caixeta Ferreira and Cristiane Taniguti ## -## ## -## First version: 2020/05/26 ## -## License: GNU General Public License version 3 or later ## -## ## -####################################################################### - -globalVariables(c("grp", "for.split", ".", "pos", "prob", "pos2", - "allele","parents.homologs", "progeny.homologs", "homolog")) -globalVariables(c("V1", "V2", "V3", "V4", - "H1_P1", "H1_P2", "H2_P1", "H2_P2", - "P1_H1", "P1_H2", "P2_H1", "P2_H2")) - -#' Generates data.frame with parents estimated haplotypes -#' -#' @param ... objects of class sequence -#' @param group_names vector of characters defining the group names -#' @param map.function "kosambi" or "haldane" according to which was used to build the map -#' @param ref_alt_alleles TRUE to return parents haplotypes as reference and alternative ref_alt_alleles codification -#' -#' @return data.frame with group ID (group), marker number (mk.number) -#' and names (mk.names), position in centimorgan (dist) and parents haplotypes -#' (P1_1, P1_2, P2_1, P2_2) -#' -#' @examples -#' \donttest{ -#' data("onemap_example_out") -#' twopts <- rf_2pts(onemap_example_out) -#' lg1 <- make_seq(twopts, 1:5) -#' lg1.map <- map(lg1) -#' parents_haplotypes(lg1.map) -#' } -#' @author Getulio Caixeta Ferreira, \email{getulio.caifer@@gmail.com} -#' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} -#' @export -parents_haplotypes <- function(..., group_names=NULL, map.function = "kosambi", ref_alt_alleles = FALSE){ - input_raw <- list(...) - if(length(input_raw) == 0) stop("argument '...' missing, with no default") - # Accept list of sequences or list of list of sequences - if(inherits(input_raw[[1]], "sequence")) input.map <- input_raw else input.map <- unlist(input_raw, recursive = FALSE) - if(!all(sapply(input.map, function(x) inherits(x, "sequence")))) stop(paste("Input objects must be of 'sequence' class. \n")) - if(is.null(group_names)) group_names <- paste("Group",seq(input.map), sep = " - ") - - if(all(sapply(input_raw, function(x) inherits(x, "sequence")))){ - n <- length(sapply(input_raw, function(x) inherits(x, "sequence"))) - } else n <- 1 - - input_temp <- input_raw - out_dat <- data.frame() - for(z in 1:n){ - if(all(sapply(input_temp, function(x) inherits(x, "sequence")))) input <- input_temp[[z]] - marnames <- colnames(input$data.name$geno)[input$seq.num] - if(length(input$seq.rf) == 1 && input$seq.rf == -1) { - # no information available for the order - warning("\nParameters not estimated.\n\n") - } else { - # convert numerical linkage phases to strings - link.phases <- matrix(NA,length(input$seq.num),2) - link.phases[1,] <- rep(1,2) - for (i in 1:length(input$seq.phases)) { - switch(EXPR=input$seq.phases[i], - link.phases[i+1,] <- link.phases[i,]*c(1,1), - link.phases[i+1,] <- link.phases[i,]*c(1,-1), - link.phases[i+1,] <- link.phases[i,]*c(-1,1), - link.phases[i+1,] <- link.phases[i,]*c(-1,-1), - ) - } - - ## display results - marnumbers <- input$seq.num - distances <- if(map.function == "kosambi") c(0,cumsum(kosambi(input$seq.rf))) else if(map.function == "haldane") c(0,cumsum(haldane(input$seq.rf))) - ## whith diplotypes for class 'outcross' - if(inherits(input$data.name, c("outcross", "f2"))){ - ## create diplotypes from segregation types and linkage phases - link.phases <- apply(link.phases,1,function(x) paste(as.character(x),collapse=".")) - parents <- matrix("",length(input$seq.num),4) - for (i in 1:length(input$seq.num)) - if(!is.null(input$data.name$ref_alt_alleles) & ref_alt_alleles){ - # Changing by reference and alternative alleles - parents[i,] <- return_geno_ref_alt(link.phases = link.phases[i], - ref_alt = input$data.name$ref_alt_alleles[input$seq.num[i],]) - } else parents[i,] <- return_geno(segr.type = input$data.name$segr.type[input$seq.num[i]], link.phases = link.phases[i]) - out_dat_temp <- data.frame(group= group_names[z], mk.number = marnumbers, mk.names = marnames, dist = as.numeric(distances), - P1_1 = parents[,1], - P1_2 = parents[,2], - P2_1 = parents[,3], - P2_2 = parents[,4]) - out_dat <- rbind(out_dat, out_dat_temp) - } - ## whithout diplotypes for other classes - else if(inherits(input$data.name, c("backcross", "riself", "risib"))){ - warning("There is only a possible phase for this cross type\n") - } else warning("invalid cross type") - } - } - - return(out_dat) -} - - -#' Generate data.frame with genotypes estimated by HMM and its probabilities -#' -#' @param ... Map(s) or list(s) of maps. Object(s) of class sequence. -#' @param ind vector with individual index to be evaluated or "all" to include all individuals -#' @param most_likely logical; if \code{TRUE}, the most likely genotype receive 1 and all the rest 0. -#' If there are more than one most likely both receive 0.5. -#' if FALSE (default) the genotype probability is plotted. -#' @param group_names Names of the groups. -#' -#' @return a data.frame information: individual (ind) and marker ID, group ID (grp), position in centimorgan (pos), -#' genotypes probabilities (prob), parents, and the parents homologs and the allele IDs. -#' -#' @examples -#' \donttest{ -#' data("onemap_example_out") -#' twopts <- rf_2pts(onemap_example_out) -#' lg1 <- make_seq(twopts, 1:5) -#' lg1.map <- map(lg1) -#' progeny_haplotypes(lg1.map) -#' } -#' @import dplyr -#' @import tidyr -#' -#' @author Getulio Caixeta Ferreira, \email{getulio.caifer@@gmail.com} -#' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} -#' @export -progeny_haplotypes <- function(..., - ind = 1, - group_names=NULL, - most_likely = FALSE){ - #input map - input <- list(...) - if(length(input) == 0) stop("argument '...' missing, with no default") - # Accept list of sequences or list of list of sequences - if(inherits(input[[1]], "sequence")) input.map <- input else input.map <- unlist(input, recursive = FALSE) - if(!all(sapply(input.map, function(x) inherits(x, "sequence")))) stop(paste("Input objects must be of 'sequence' class. \n")) - if(is.null(group_names)) group_names <- paste("Group",seq(input.map), sep = " - ") - n.mar <- sapply(input.map, function(x) length(x$seq.num)) - n.ind <- sapply(input.map, function(x) ncol(x$probs))/n.mar - ind.names <- lapply(input.map, function(x) rownames(x$data.name$geno)) - ind.names <- unique(unlist(ind.names)) - if(length(unique(n.ind)) != 1) stop("At least one of the sequences have different number of individuals in dataset.") - n.ind <- unique(n.ind) - if(is.null(ind.names)) ind.names <- 1:n.ind - if(ind[1] == "all"){ - ind <- 1:n.ind - } - - probs <- lapply(1:length(input.map), function(x) cbind(ind = rep(1:n.ind, each = n.mar[x]), - grp = group_names[x], - marker = input.map[[x]]$seq.num, - pos = c(0,cumsum(kosambi(input.map[[x]]$seq.rf))), - as.data.frame(t(input.map[[x]]$probs)))) - probs <- lapply(probs, function(x) split.data.frame(x, x$ind)[ind]) - - if(inherits(input.map[[1]]$data.name, "outcross") | inherits(input.map[[1]]$data.name, "f2")){ - phase <- list('1' = c(1,2,3,4), - '2' = c(2,1,4,3), - '3' = c(3,4,1,2), - "4" = c(4,3,2,1)) - - seq.phase <- lapply(input.map, function(x) c(1,x$seq.phases)) - - # Adjusting phases - for(g in seq_along(input.map)){ - for(i in seq_along(ind)){ - for(m in seq(n.mar[g])){ - probs[[g]][[i]][m:n.mar[g],5:8] <- probs[[g]][[i]][m:n.mar[g],phase[[seq.phase[[g]][m]]]+4] - } - } - } - - # If there are two most probably genotypes both will receive 0.5 - probs <- do.call(rbind,lapply(probs, function(x) do.call(rbind, x))) - - if(most_likely){ - probs[,5:8] <- t(apply(probs[,5:8], 1, function(x) as.numeric(x == max(x))/sum(x == max(x)))) - } - - # When P1_H1 it means the allele in homolog 1 of the parent 1 - # when H1_P1 is the parent 1 allele in the progeny homolog 1 - if(inherits(input.map[[1]]$data.name, "outcross")){ - probs <- probs %>% - mutate(P1_H1 = V1 + V2, - P1_H2 = V3 + V4, - P2_H1 = V1 + V3, - P2_H2 = V2 + V4) %>% - select(ind, marker, grp, pos, P1_H1, P1_H2, P2_H1, P2_H2) %>% - gather(parents, prob, P1_H1, P1_H2, P2_H1, P2_H2) - - new.col <- t(sapply(strsplit(probs$parents, "_"), "[", 1:2)) - colnames(new.col) <- c("parents", "parents.homologs") - cross <- "outcross" - } else { - probs <- probs %>% - mutate(H1_P1 = V1 + V2, - H1_P2 = V3 + V4, - H2_P1 = V1 + V3, - H2_P2 = V2 + V4) %>% - select(ind, marker, grp, pos, H1_P1, H1_P2, H2_P1, H2_P2) %>% - gather(parents, prob, H1_P1, H1_P2, H2_P1, H2_P2) - - new.col <- t(sapply(strsplit(probs$parents, "_"), "[", 1:2)) - colnames(new.col) <- c("progeny.homologs", "parents") - cross <- "f2" - } - } else { - probs <- do.call(rbind,lapply(probs, function(x) do.call(rbind, x))) - if(most_likely){ - probs[,5:6] <- t(apply(probs[,5:6], 1, function(x) as.numeric(x == max(x))/sum(x == max(x)))) - } - - if (inherits(input.map[[1]]$data.name, c("backcross")) | inherits(input.map[[1]]$data.name, c("riself", "risib"))){ - if(inherits(input.map[[1]]$data.name, c("backcross"))){ - cross <- "backcross" - probs <- probs %>% - mutate(H1_P1 = V1 + V2, # homozygote parent - H1_P2 = 0, - H2_P1 = V2, - H2_P2 = V1) - } else if (inherits(input.map[[1]]$data.name, c("riself", "risib"))){ - cross <- "rils" - probs <- probs %>% - mutate(H1_P1 = V1, - H1_P2 = V2, - H2_P1 = V1, - H2_P2 = V2) - } - probs <- probs %>% select(ind, marker, grp, pos, H1_P1, H1_P2, H2_P1, H2_P2) %>% - gather(parents, prob, H1_P1, H1_P2, H2_P1, H2_P2) - new.col <- t(sapply(strsplit(probs$parents, "_"), "[", 1:2)) - colnames(new.col) <- c("progeny.homologs", "parents") - } - } - - probs <- cbind(probs, new.col) - probs <- cbind(probs[,-5], allele = probs[,5]) - probs <- as.data.frame(probs) - probs$marker = colnames(input.map[[1]]$data.name$geno)[probs$marker] - probs$ind <- ind.names[probs$ind] - - if(most_likely) flag <- "most.likely" else flag <- "by.probs" - - class(probs) <- c("onemap_progeny_haplotypes", cross, "data.frame", flag) - return(probs) -} - -##' Plots progeny haplotypes -##' -##' Figure is generated with the haplotypes for each selected individual. As a representation, the recombination breakpoints are here considered -##' to be in the mean point of the distance between two markers. It is important to highlight that it did not reflects the exact breakpoint position, -##' specially if the genetic map have low resolution. -##' -##' @param x object of class onemap_progeny_haplotypes -##' @param col Color of parents' homologous. -##' @param position "split" or "stack"; if "split" (default) the alleles' are plotted separately. if "stack" the parents' alleles are plotted together. -##' @param show_markers logical; if \code{TRUE}, the markers (default) are plotted. -##' @param main An overall title for the plot; default is \code{NULL}. -##' @param ncol number of columns of the facet_wrap -##' @param ... currently ignored -##' -##' @method plot onemap_progeny_haplotypes -##' -##' @examples -##' \donttest{ -#' data("onemap_example_out") -#' twopts <- rf_2pts(onemap_example_out) -#' lg1 <- make_seq(twopts, 1:5) -#' lg1.map <- map(lg1) -#' plot(progeny_haplotypes(lg1.map)) -##' } -##' -##' @return a ggplot graphic -##' -##' @import ggplot2 -#' @import dplyr -#' @import tidyr -#' -##' @author Getulio Caixeta Ferreira, \email{getulio.caifer@@gmail.com} -##' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} -##' -##' @export -plot.onemap_progeny_haplotypes <- function(x, - col = NULL, - position = "stack", - show_markers = TRUE, - main = "Genotypes", ncol=4, ...){ - - if(inherits(x, "outcross")){ - n <- c("H1" = "P1", "H2" = "P2") - progeny.homologs <- names(n)[match(x$parents, n)] - probs <- cbind(x, progeny.homologs) - } else { - probs <- x - } - - probs <- probs %>% group_by(ind, grp, allele) %>% - do(rbind(.,.[nrow(.),])) %>% - do(mutate(., - pos2 = c(0,pos[-1]-diff(pos)/2), # Because we don't know exactly where - # the recombination occurs, we ilustrate it in the mean point between - # markers - pos = c(pos[-nrow(.)], NA))) - - if(inherits(x, "outcross")){ - p <- ggplot(probs, aes(x = pos, col=allele, alpha = prob)) + ggtitle(main) - } else { - p <- ggplot(probs, aes(x = pos, col=parents, alpha = prob)) + ggtitle(main) - } - - p <- p + facet_wrap(~ ind + grp , ncol = ncol) + - scale_alpha_continuous(range = c(0,1)) + - guides(fill = guide_legend(reverse = TRUE)) + - labs(alpha = "Prob", col = "Allele", x = "position (cM)") - - if(is.null(col)) p <- p + scale_color_brewer(palette="Set1") - else p <- p + scale_color_manual(values = rev(col)) - - if(position == "stack"){ - p <- p + geom_line(aes(x = pos2, y = progeny.homologs), size = ifelse(show_markers, 4, 5)) + labs(y = "progeny homologs") - if(show_markers) p <- p + geom_point(aes(y = progeny.homologs), size = 5, stroke = 2, na.rm = T, shape = "|") - } - if(position == "split"){ - p <- p + geom_line(aes(x = pos2, y = allele), size = ifelse(show_markers, 4, 5)) - if(show_markers) p <- p + geom_point(aes(y = allele), size = 5, stroke = 2, na.rm = T, shape = "|") - } - return(p) -} - -#' Plot number of breakpoints by individuals -#' -#' Generate graphic with the number of break points for each individual -#' considering the most likely genotypes estimated by the HMM. -#' Genotypes with same probability for two genotypes are removed. -#' By now, only available for outcrossing and f2 intercross. -#' -#' @param x object of class onemap_progeny_haplotypes -#' -#' @examples -#' \donttest{ -#' data("onemap_example_out") -#' twopts <- rf_2pts(onemap_example_out) -#' lg1 <- make_seq(twopts, 1:5) -#' lg1.map <- map(lg1) -#' progeny_haplotypes_counts(progeny_haplotypes(lg1.map, most_likely = TRUE)) -#' } -#' -#' @return a \code{data.frame} with columns individuals ID (ind), group ID (grp), -#' homolog (homolog) and counts of breakpoints -#' -#' @import dplyr -#' @import tidyr -#'@export -progeny_haplotypes_counts <- function(x){ - if(!inherits(x, "onemap_progeny_haplotypes")) stop("Input need is not of class onemap_progeny_haplotyes") - if(!inherits(x, "most.likely")) stop("The most likely genotypes must receive maximum probability (1)") - cross <- class(x)[2] - - # Some genotypes receives prob of 0.5, here we need to make a decision about them - # Here we keep the genotype of the marker before it - doubt <- x[which(x$prob == 0.5),] - if(dim(doubt)[1] > 0){ - if(any(which(x$prob == 0.5)) == 1){ - x[1, "prob"] <- x[2, "prob"] - } - repl <- x[which(x$prob == 0.5)-1,"prob"] - x[which(x$prob == 0.5),"prob"] <- repl - } - - x <- x[which(x$prob == 1),] - x <- x[order(x$ind, x$grp, x$prob, x$parents,x$pos),] - - if(inherits(x, "outcross")){ - counts <- x %>% group_by(ind, grp) %>% - mutate(seq = sequence(rle(as.character(allele))$length) == 1) %>% - group_by(ind, grp, parents) %>% - summarise(counts = sum(seq) -1,.groups = "keep") %>% ungroup() - counts$parents <- gsub("P", "H", counts$parents) - - } else { - counts <- x %>% group_by(ind, grp, progeny.homologs) %>% - mutate(seq = sequence(rle(as.character(parents))$length) == 1) %>% - summarise(counts = sum(seq) -1) %>% ungroup() - } - colnames(counts)[3] <- "homolog" - class(counts) <- c("onemap_progeny_haplotypes_counts", cross, "data.frame") - return(counts) -} - - -globalVariables(c("counts", "colorRampPalette", "alleles")) - - -##' Plot recombination breakpoints counts for each individual -##' -##' @param x object of class onemap_progeny_haplotypes_counts -##' @param by_homolog logical, if TRUE plots counts by homolog (two for each individuals), if FALSE plots total counts by individual -##' @param n.graphics integer defining the number of graphics to be plotted, they separate the individuals in different plots -##' @param ncol integer defining the number of columns in plot -##' @param ... currently ignored -##' -##' @return a ggplot graphic -##' -##' @examples -##' \donttest{ -#' data("onemap_example_out") -#' twopts <- rf_2pts(onemap_example_out) -#' lg1 <- make_seq(twopts, 1:5) -#' lg1.map <- map(lg1) -#' prog.haplo <- progeny_haplotypes(lg1.map, most_likely = TRUE) -#' plot(progeny_haplotypes_counts(prog.haplo)) -##' } -##' -##' @method plot onemap_progeny_haplotypes_counts -##' @import ggplot2 -##' @importFrom ggpubr ggarrange -##' @import dplyr -##' @import tidyr -##' @importFrom RColorBrewer brewer.pal -##' @importFrom grDevices colorRamp colorRampPalette -##' -##' @export -plot.onemap_progeny_haplotypes_counts <- function(x, - by_homolog = FALSE, - n.graphics =NULL, - ncol=NULL, ...){ - if(!inherits(x, "onemap_progeny_haplotypes_counts")) stop("Input need is not of class onemap_progeny_haplotyes_counts") - - p <- list() - n.ind <- length(unique(x$ind)) - nb.cols <- n.ind - mycolors <- colorRampPalette(brewer.pal(12, "Paired"))(nb.cols) - set.seed(20) - mycolors <- sample(mycolors) - - if(by_homolog){ - if(is.null(n.graphics) & is.null(ncol)){ - n.ind <- dim(x)[1]/2 - if(n.ind/25 <= 1) { - n.graphics = 1 - ncol=1 - }else { n.graphics = round(n.ind/25,0) - ncol=round(n.ind/25,0) - } - } - size <- dim(x)[1] - if(size%%n.graphics == 0){ - div.n.graphics <- rep(1:n.graphics, each= size/n.graphics) - } else { - div.n.graphics <- c(rep(1:n.graphics, each = round(size/n.graphics,0)), rep(n.graphics, size%%n.graphics)) - } - - y_lim_counts <- max(x$counts) - div.n.graphics <- div.n.graphics[1:size] - p <- x %>% mutate(div.n.graphics = div.n.graphics) %>% - split(., .$div.n.graphics) %>% - lapply(., function(x) ggplot(x, aes(x=homolog, y=counts)) + - geom_bar(stat="identity", aes(fill=grp)) + theme_minimal() + - coord_flip() + - scale_fill_manual(values=mycolors) + - facet_grid(ind ~ ., switch = "y") + - theme(axis.title.y = element_blank(), - axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1), - strip.text.y.left = element_text(angle = 0)) + - labs(fill="groups") + - ylim(0,y_lim_counts) - ) - } else { - x <- x %>% ungroup %>% group_by(ind, grp) %>% - summarise(counts = sum(counts)) - - - if(is.null(n.graphics) & is.null(ncol)){ - if(n.ind/25 <= 1) { - n.graphics = 1 - ncol=1 - }else { - n.graphics = round(n.ind/25,0) - ncol=round(n.ind/25,0) - } - } - - size <-n.ind - if(size%%n.graphics == 0){ - div.n.graphics <- rep(1:n.graphics, each= size/n.graphics) - } else { - div.n.graphics <- c(rep(1:n.graphics, each = round(size/n.graphics,0)),rep(n.graphics, size%%n.graphics)) - } - div.n.graphics <- div.n.graphics[1:n.ind] - div.n.graphics <- rep(div.n.graphics, each = length(unique(x$grp))) - - x$ind <- factor(as.character(x$ind), levels = sort(as.character(unique(x$ind)))) - - temp <- x %>% ungroup() %>% group_by(ind) %>% - summarise(total = sum(counts)) - - y_lim_counts <- max(temp$total) - p <- x %>% ungroup() %>% mutate(div.n.graphics = div.n.graphics) %>% - split(., .$div.n.graphics) %>% - lapply(., function(x) ggplot(x, aes(x=ind, y=counts, fill=grp)) + - geom_bar(stat="identity") + coord_flip() + - scale_fill_manual(values=mycolors) + - theme(axis.title.y = element_blank(), - axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) + - labs(fill="groups") + - ylim(0,y_lim_counts) - ) - } - p <- ggarrange(plotlist = p, common.legend = T, label.x = 1, ncol = ncol, nrow = round(n.graphics/ncol,0)) - return(p) -} +####################################################################### +## ## +## Package: onemap ## +## ## +## File: write_haplotypes.R ## +## Contains: parents_haplotypes, progeny_haplotypes, ## +## plot.onemap_progeny_haplotypes, ## +## plot.onemap_progeny_haplotypes_counts ## +## ## +## Written by Getulio Caixeta Ferreira and Cristiane Taniguti ## +## ## +## First version: 2020/05/26 ## +## License: GNU General Public License version 3 or later ## +## ## +####################################################################### + +globalVariables(c("grp", "for.split", ".", "pos", "prob", "pos2", + "allele","parents.homologs", "progeny.homologs", "homolog")) +globalVariables(c("V1", "V2", "V3", "V4", + "H1_P1", "H1_P2", "H2_P1", "H2_P2", + "P1_H1", "P1_H2", "P2_H1", "P2_H2")) + +#' Generates data.frame with parents estimated haplotypes +#' +#' @param ... objects of class sequence +#' @param group_names vector of characters defining the group names +#' @param map.function "kosambi" or "haldane" according to which was used to build the map +#' @param ref_alt_alleles TRUE to return parents haplotypes as reference and alternative ref_alt_alleles codification +#' +#' @return data.frame with group ID (group), marker number (mk.number) +#' and names (mk.names), position in centimorgan (dist) and parents haplotypes +#' (P1_1, P1_2, P2_1, P2_2) +#' +#' @examples +#' \donttest{ +#' data("onemap_example_out") +#' twopts <- rf_2pts(onemap_example_out) +#' lg1 <- make_seq(twopts, 1:5) +#' lg1.map <- map(lg1) +#' parents_haplotypes(lg1.map) +#' } +#' @author Getulio Caixeta Ferreira, \email{getulio.caifer@@gmail.com} +#' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} +#' @export +parents_haplotypes <- function(..., group_names=NULL, map.function = "kosambi", ref_alt_alleles = FALSE){ + input_raw <- list(...) + if(length(input_raw) == 0) stop("argument '...' missing, with no default") + # Accept list of sequences or list of list of sequences + if(inherits(input_raw[[1]], "sequence")) input.map <- input_raw else input.map <- unlist(input_raw, recursive = FALSE) + if(!all(sapply(input.map, function(x) inherits(x, "sequence")))) stop(paste("Input objects must be of 'sequence' class. \n")) + if(is.null(group_names)) group_names <- paste("Group",seq(input.map), sep = " - ") + + if(all(sapply(input_raw, function(x) inherits(x, "sequence")))){ + n <- length(sapply(input_raw, function(x) inherits(x, "sequence"))) + } else n <- 1 + + input_temp <- input_raw + out_dat <- data.frame() + for(z in 1:n){ + if(all(sapply(input_temp, function(x) inherits(x, "sequence")))) input <- input_temp[[z]] + marnames <- colnames(input$data.name$geno)[input$seq.num] + if(length(input$seq.rf) == 1 && input$seq.rf == -1) { + # no information available for the order + warning("\nParameters not estimated.\n\n") + } else { + # convert numerical linkage phases to strings + link.phases <- matrix(NA,length(input$seq.num),2) + link.phases[1,] <- rep(1,2) + for (i in 1:length(input$seq.phases)) { + switch(EXPR=input$seq.phases[i], + link.phases[i+1,] <- link.phases[i,]*c(1,1), + link.phases[i+1,] <- link.phases[i,]*c(1,-1), + link.phases[i+1,] <- link.phases[i,]*c(-1,1), + link.phases[i+1,] <- link.phases[i,]*c(-1,-1), + ) + } + + ## display results + marnumbers <- input$seq.num + distances <- if(map.function == "kosambi") c(0,cumsum(kosambi(input$seq.rf))) else if(map.function == "haldane") c(0,cumsum(haldane(input$seq.rf))) + ## whith diplotypes for class 'outcross' + if(inherits(input$data.name, c("outcross", "f2"))){ + ## create diplotypes from segregation types and linkage phases + link.phases <- apply(link.phases,1,function(x) paste(as.character(x),collapse=".")) + parents <- matrix("",length(input$seq.num),4) + for (i in 1:length(input$seq.num)) + if(!is.null(input$data.name$ref_alt_alleles) & ref_alt_alleles){ + # Changing by reference and alternative alleles + parents[i,] <- return_geno_ref_alt(link.phases = link.phases[i], + ref_alt = input$data.name$ref_alt_alleles[input$seq.num[i],]) + } else parents[i,] <- return_geno(segr.type = input$data.name$segr.type[input$seq.num[i]], link.phases = link.phases[i]) + out_dat_temp <- data.frame(group= group_names[z], mk.number = marnumbers, mk.names = marnames, dist = as.numeric(distances), + P1_1 = parents[,1], + P1_2 = parents[,2], + P2_1 = parents[,3], + P2_2 = parents[,4]) + out_dat <- rbind(out_dat, out_dat_temp) + } + ## whithout diplotypes for other classes + else if(inherits(input$data.name, c("backcross", "riself", "risib"))){ + warning("There is only a possible phase for this cross type\n") + } else warning("invalid cross type") + } + } + + return(out_dat) +} + + +#' Generate data.frame with genotypes estimated by HMM and its probabilities +#' +#' @param ... Map(s) or list(s) of maps. Object(s) of class sequence. +#' @param ind vector with individual index to be evaluated or "all" to include all individuals +#' @param most_likely logical; if \code{TRUE}, the most likely genotype receive 1 and all the rest 0. +#' If there are more than one most likely both receive 0.5. +#' if FALSE (default) the genotype probability is plotted. +#' @param group_names Names of the groups. +#' +#' @return a data.frame information: individual (ind) and marker ID, group ID (grp), position in centimorgan (pos), +#' genotypes probabilities (prob), parents, and the parents homologs and the allele IDs. +#' +#' @examples +#' \donttest{ +#' data("onemap_example_out") +#' twopts <- rf_2pts(onemap_example_out) +#' lg1 <- make_seq(twopts, 1:5) +#' lg1.map <- map(lg1) +#' progeny_haplotypes(lg1.map) +#' } +#' @import dplyr +#' @import tidyr +#' +#' @author Getulio Caixeta Ferreira, \email{getulio.caifer@@gmail.com} +#' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} +#' @export +progeny_haplotypes <- function(..., + ind = 1, + group_names=NULL, + most_likely = FALSE){ + #input map + input <- list(...) + if(length(input) == 0) stop("argument '...' missing, with no default") + # Accept list of sequences or list of list of sequences + if(inherits(input[[1]], "sequence")) input.map <- input else input.map <- unlist(input, recursive = FALSE) + if(!all(sapply(input.map, function(x) inherits(x, "sequence")))) stop(paste("Input objects must be of 'sequence' class. \n")) + if(is.null(group_names)) group_names <- paste("Group",seq(input.map), sep = " - ") + n.mar <- sapply(input.map, function(x) length(x$seq.num)) + n.ind <- sapply(input.map, function(x) ncol(x$probs))/n.mar + ind.names <- lapply(input.map, function(x) rownames(x$data.name$geno)) + ind.names <- unique(unlist(ind.names)) + if(length(unique(n.ind)) != 1) stop("At least one of the sequences have different number of individuals in dataset.") + n.ind <- unique(n.ind) + if(is.null(ind.names)) ind.names <- 1:n.ind + if(ind[1] == "all"){ + ind <- 1:n.ind + } + + probs <- lapply(1:length(input.map), function(x) cbind(ind = rep(1:n.ind, each = n.mar[x]), + grp = group_names[x], + marker = input.map[[x]]$seq.num, + pos = c(0,cumsum(kosambi(input.map[[x]]$seq.rf))), + as.data.frame(t(input.map[[x]]$probs)))) + probs <- lapply(probs, function(x) split.data.frame(x, x$ind)[ind]) + + if(inherits(input.map[[1]]$data.name, "outcross") | inherits(input.map[[1]]$data.name, "f2")){ + phase <- list('1' = c(1,2,3,4), + '2' = c(2,1,4,3), + '3' = c(3,4,1,2), + "4" = c(4,3,2,1)) + + seq.phase <- lapply(input.map, function(x) c(1,x$seq.phases)) + + # Adjusting phases + for(g in seq_along(input.map)){ + for(i in seq_along(ind)){ + for(m in seq(n.mar[g])){ + probs[[g]][[i]][m:n.mar[g],5:8] <- probs[[g]][[i]][m:n.mar[g],phase[[seq.phase[[g]][m]]]+4] + } + } + } + + # If there are two most probably genotypes both will receive 0.5 + probs <- do.call(rbind,lapply(probs, function(x) do.call(rbind, x))) + + if(most_likely){ + probs[,5:8] <- t(apply(probs[,5:8], 1, function(x) as.numeric(x == max(x))/sum(x == max(x)))) + } + + # When P1_H1 it means the allele in homolog 1 of the parent 1 + # when H1_P1 is the parent 1 allele in the progeny homolog 1 + if(inherits(input.map[[1]]$data.name, "outcross")){ + probs <- probs %>% + mutate(P1_H1 = V1 + V2, + P1_H2 = V3 + V4, + P2_H1 = V1 + V3, + P2_H2 = V2 + V4) %>% + select(ind, marker, grp, pos, P1_H1, P1_H2, P2_H1, P2_H2) %>% + gather(parents, prob, P1_H1, P1_H2, P2_H1, P2_H2) + + new.col <- t(sapply(strsplit(probs$parents, "_"), "[", 1:2)) + colnames(new.col) <- c("parents", "parents.homologs") + cross <- "outcross" + } else { + probs <- probs %>% + mutate(H1_P1 = V1 + V2, + H1_P2 = V3 + V4, + H2_P1 = V1 + V3, + H2_P2 = V2 + V4) %>% + select(ind, marker, grp, pos, H1_P1, H1_P2, H2_P1, H2_P2) %>% + gather(parents, prob, H1_P1, H1_P2, H2_P1, H2_P2) + + new.col <- t(sapply(strsplit(probs$parents, "_"), "[", 1:2)) + colnames(new.col) <- c("progeny.homologs", "parents") + cross <- "f2" + } + } else { + probs <- do.call(rbind,lapply(probs, function(x) do.call(rbind, x))) + if(most_likely){ + probs[,5:6] <- t(apply(probs[,5:6], 1, function(x) as.numeric(x == max(x))/sum(x == max(x)))) + } + + if (inherits(input.map[[1]]$data.name, c("backcross")) | inherits(input.map[[1]]$data.name, c("riself", "risib"))){ + if(inherits(input.map[[1]]$data.name, c("backcross"))){ + cross <- "backcross" + probs <- probs %>% + mutate(H1_P1 = V1 + V2, # homozygote parent + H1_P2 = 0, + H2_P1 = V2, + H2_P2 = V1) + } else if (inherits(input.map[[1]]$data.name, c("riself", "risib"))){ + cross <- "rils" + probs <- probs %>% + mutate(H1_P1 = V1, + H1_P2 = V2, + H2_P1 = V1, + H2_P2 = V2) + } + probs <- probs %>% select(ind, marker, grp, pos, H1_P1, H1_P2, H2_P1, H2_P2) %>% + gather(parents, prob, H1_P1, H1_P2, H2_P1, H2_P2) + new.col <- t(sapply(strsplit(probs$parents, "_"), "[", 1:2)) + colnames(new.col) <- c("progeny.homologs", "parents") + } + } + + probs <- cbind(probs, new.col) + probs <- cbind(probs[,-5], allele = probs[,5]) + probs <- as.data.frame(probs) + probs$marker = colnames(input.map[[1]]$data.name$geno)[probs$marker] + probs$ind <- ind.names[probs$ind] + + if(most_likely) flag <- "most.likely" else flag <- "by.probs" + + class(probs) <- c("onemap_progeny_haplotypes", cross, "data.frame", flag) + return(probs) +} + +##' Plots progeny haplotypes +##' +##' Figure is generated with the haplotypes for each selected individual. As a representation, the recombination breakpoints are here considered +##' to be in the mean point of the distance between two markers. It is important to highlight that it did not reflects the exact breakpoint position, +##' specially if the genetic map have low resolution. +##' +##' @param x object of class onemap_progeny_haplotypes +##' @param col Color of parents' homologous. +##' @param position "split" or "stack"; if "split" (default) the alleles' are plotted separately. if "stack" the parents' alleles are plotted together. +##' @param show_markers logical; if \code{TRUE}, the markers (default) are plotted. +##' @param main An overall title for the plot; default is \code{NULL}. +##' @param ncol number of columns of the facet_wrap +##' @param ... currently ignored +##' +##' @method plot onemap_progeny_haplotypes +##' +##' @examples +##' \donttest{ +#' data("onemap_example_out") +#' twopts <- rf_2pts(onemap_example_out) +#' lg1 <- make_seq(twopts, 1:5) +#' lg1.map <- map(lg1) +#' plot(progeny_haplotypes(lg1.map)) +##' } +##' +##' @return a ggplot graphic +##' +##' @import ggplot2 +#' @import dplyr +#' @import tidyr +#' +##' @author Getulio Caixeta Ferreira, \email{getulio.caifer@@gmail.com} +##' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} +##' +##' @export +plot.onemap_progeny_haplotypes <- function(x, + col = NULL, + position = "stack", + show_markers = TRUE, + main = "Genotypes", ncol=4, ...){ + + if(inherits(x, "outcross")){ + n <- c("H1" = "P1", "H2" = "P2") + progeny.homologs <- names(n)[match(x$parents, n)] + probs <- cbind(x, progeny.homologs) + } else { + probs <- x + } + + probs <- probs %>% group_by(ind, grp, allele) %>% + do(rbind(.,.[nrow(.),])) %>% + do(mutate(., + pos2 = c(0,pos[-1]-diff(pos)/2), # Because we don't know exactly where + # the recombination occurs, we ilustrate it in the mean point between + # markers + pos = c(pos[-nrow(.)], NA))) + + if(inherits(x, "outcross")){ + p <- ggplot(probs, aes(x = pos, col=allele, alpha = prob)) + ggtitle(main) + } else { + p <- ggplot(probs, aes(x = pos, col=parents, alpha = prob)) + ggtitle(main) + } + + p <- p + facet_wrap(~ ind + grp , ncol = ncol) + + scale_alpha_continuous(range = c(0,1)) + + guides(fill = guide_legend(reverse = TRUE)) + + labs(alpha = "Prob", col = "Allele", x = "position (cM)") + + if(is.null(col)) p <- p + scale_color_brewer(palette="Set1") + else p <- p + scale_color_manual(values = rev(col)) + + if(position == "stack"){ + p <- p + geom_line(aes(x = pos2, y = progeny.homologs), size = ifelse(show_markers, 4, 5)) + labs(y = "progeny homologs") + if(show_markers) p <- p + geom_point(aes(y = progeny.homologs), size = 5, stroke = 2, na.rm = T, shape = "|") + } + if(position == "split"){ + p <- p + geom_line(aes(x = pos2, y = allele), size = ifelse(show_markers, 4, 5)) + if(show_markers) p <- p + geom_point(aes(y = allele), size = 5, stroke = 2, na.rm = T, shape = "|") + } + return(p) +} + +#' Plot number of breakpoints by individuals +#' +#' Generate graphic with the number of break points for each individual +#' considering the most likely genotypes estimated by the HMM. +#' Genotypes with same probability for two genotypes are removed. +#' By now, only available for outcrossing and f2 intercross. +#' +#' @param x object of class onemap_progeny_haplotypes +#' +#' @examples +#' \donttest{ +#' data("onemap_example_out") +#' twopts <- rf_2pts(onemap_example_out) +#' lg1 <- make_seq(twopts, 1:5) +#' lg1.map <- map(lg1) +#' progeny_haplotypes_counts(progeny_haplotypes(lg1.map, most_likely = TRUE)) +#' } +#' +#' @return a \code{data.frame} with columns individuals ID (ind), group ID (grp), +#' homolog (homolog) and counts of breakpoints +#' +#' @import dplyr +#' @import tidyr +#'@export +progeny_haplotypes_counts <- function(x){ + if(!inherits(x, "onemap_progeny_haplotypes")) stop("Input need is not of class onemap_progeny_haplotyes") + if(!inherits(x, "most.likely")) stop("The most likely genotypes must receive maximum probability (1)") + cross <- class(x)[2] + + # Some genotypes receives prob of 0.5, here we need to make a decision about them + # Here we keep the genotype of the marker before it + doubt <- x[which(x$prob == 0.5),] + if(dim(doubt)[1] > 0){ + if(any(which(x$prob == 0.5)) == 1){ + x[1, "prob"] <- x[2, "prob"] + } + idx <- which(x$prob == 0.5)-1 + if(idx[1] == 0) idx[1] <- 1 + repl <- x[idx,"prob"] + x[which(x$prob == 0.5),"prob"] <- repl + } + + x <- x[which(x$prob == 1),] + x <- x[order(x$ind, x$grp, x$prob, x$parents,x$pos),] + + if(inherits(x, "outcross")){ + counts <- x %>% group_by(ind, grp) %>% + mutate(seq = sequence(rle(as.character(allele))$length) == 1) %>% + group_by(ind, grp, parents) %>% + summarise(counts = sum(seq) -1,.groups = "keep") %>% ungroup() + counts$parents <- gsub("P", "H", counts$parents) + + } else { + counts <- x %>% group_by(ind, grp, progeny.homologs) %>% + mutate(seq = sequence(rle(as.character(parents))$length) == 1) %>% + summarise(counts = sum(seq) -1) %>% ungroup() + } + colnames(counts)[3] <- "homolog" + class(counts) <- c("onemap_progeny_haplotypes_counts", cross, "data.frame") + return(counts) +} + + +globalVariables(c("counts", "colorRampPalette", "alleles")) + + +##' Plot recombination breakpoints counts for each individual +##' +##' @param x object of class onemap_progeny_haplotypes_counts +##' @param by_homolog logical, if TRUE plots counts by homolog (two for each individuals), if FALSE plots total counts by individual +##' @param n.graphics integer defining the number of graphics to be plotted, they separate the individuals in different plots +##' @param ncol integer defining the number of columns in plot +##' @param ... currently ignored +##' +##' @return a ggplot graphic +##' +##' @examples +##' \donttest{ +#' data("onemap_example_out") +#' twopts <- rf_2pts(onemap_example_out) +#' lg1 <- make_seq(twopts, 1:5) +#' lg1.map <- map(lg1) +#' prog.haplo <- progeny_haplotypes(lg1.map, most_likely = TRUE) +#' plot(progeny_haplotypes_counts(prog.haplo)) +##' } +##' +##' @method plot onemap_progeny_haplotypes_counts +##' @import ggplot2 +##' @importFrom ggpubr ggarrange +##' @import dplyr +##' @import tidyr +##' @importFrom RColorBrewer brewer.pal +##' @importFrom grDevices colorRamp colorRampPalette +##' +##' @export +plot.onemap_progeny_haplotypes_counts <- function(x, + by_homolog = FALSE, + n.graphics =NULL, + ncol=NULL, ...){ + if(!inherits(x, "onemap_progeny_haplotypes_counts")) stop("Input need is not of class onemap_progeny_haplotyes_counts") + + p <- list() + n.ind <- length(unique(x$ind)) + nb.cols <- n.ind + mycolors <- colorRampPalette(brewer.pal(12, "Paired"))(nb.cols) + set.seed(20) + mycolors <- sample(mycolors) + + if(by_homolog){ + if(is.null(n.graphics) & is.null(ncol)){ + n.ind <- dim(x)[1]/2 + if(n.ind/25 <= 1) { + n.graphics = 1 + ncol=1 + }else { n.graphics = round(n.ind/25,0) + ncol=round(n.ind/25,0) + } + } + size <- dim(x)[1] + if(size%%n.graphics == 0){ + div.n.graphics <- rep(1:n.graphics, each= size/n.graphics) + } else { + div.n.graphics <- c(rep(1:n.graphics, each = round(size/n.graphics,0)), rep(n.graphics, size%%n.graphics)) + } + + y_lim_counts <- max(x$counts) + div.n.graphics <- div.n.graphics[1:size] + p <- x %>% mutate(div.n.graphics = div.n.graphics) %>% + split(., .$div.n.graphics) %>% + lapply(., function(x) ggplot(x, aes(x=homolog, y=counts)) + + geom_bar(stat="identity", aes(fill=grp)) + theme_minimal() + + coord_flip() + + scale_fill_manual(values=mycolors) + + facet_grid(ind ~ ., switch = "y") + + theme(axis.title.y = element_blank(), + axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1), + strip.text.y.left = element_text(angle = 0)) + + labs(fill="groups") + + ylim(0,y_lim_counts) + ) + } else { + x <- x %>% ungroup %>% group_by(ind, grp) %>% + summarise(counts = sum(counts)) + + + if(is.null(n.graphics) & is.null(ncol)){ + if(n.ind/25 <= 1) { + n.graphics = 1 + ncol=1 + }else { + n.graphics = round(n.ind/25,0) + ncol=round(n.ind/25,0) + } + } + + size <-n.ind + if(size%%n.graphics == 0){ + div.n.graphics <- rep(1:n.graphics, each= size/n.graphics) + } else { + div.n.graphics <- c(rep(1:n.graphics, each = round(size/n.graphics,0)),rep(n.graphics, size%%n.graphics)) + } + div.n.graphics <- div.n.graphics[1:n.ind] + div.n.graphics <- rep(div.n.graphics, each = length(unique(x$grp))) + + x$ind <- factor(as.character(x$ind), levels = sort(as.character(unique(x$ind)))) + + temp <- x %>% ungroup() %>% group_by(ind) %>% + summarise(total = sum(counts)) + + y_lim_counts <- max(temp$total) + p <- x %>% ungroup() %>% mutate(div.n.graphics = div.n.graphics) %>% + split(., .$div.n.graphics) %>% + lapply(., function(x) ggplot(x, aes(x=ind, y=counts, fill=grp)) + + geom_bar(stat="identity") + coord_flip() + + scale_fill_manual(values=mycolors) + + theme(axis.title.y = element_blank(), + axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) + + labs(fill="groups") + + ylim(0,y_lim_counts) + ) + } + p <- ggarrange(plotlist = p, common.legend = T, label.x = 1, ncol = ncol, nrow = round(n.graphics/ncol,0)) + return(p) +} From 32b599754a1fb47d62e408c05caaf95e7abefd60 Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Tue, 29 Aug 2023 07:16:29 -0500 Subject: [PATCH 28/36] bugfix --- R/create_dataset_bins.R | 298 ++++++++++++++++++++-------------------- R/write_haplotypes.R | 1 + 2 files changed, 150 insertions(+), 149 deletions(-) diff --git a/R/create_dataset_bins.R b/R/create_dataset_bins.R index f7f0ed3..9518ac7 100644 --- a/R/create_dataset_bins.R +++ b/R/create_dataset_bins.R @@ -1,149 +1,149 @@ -####################################################################### -# # -# Package: onemap # -# # -# File: create_dataset_bins.R # -# Contains: select_data_bins add_redundants # -# # -# Written by Marcelo Mollinari with minor changes by Cristiane # -# Taniguti # -# copyright (c) 2015, Marcelo Mollinari # -# # -# First version: 09/2015 # -# License: GNU General Public License version 3 # -# # -####################################################################### - -#' New dataset based on bins -#' -#' Creates a new dataset based on \code{onemap_bin} object -#' -#' Given a \code{onemap_bin} object, -#' creates a new data set where the redundant markers are -#' collapsed into bins and represented by the marker with the lower -#' amount of missing data among those on the bin. -#' -#' @aliases create_data_bins -#' @param input.obj an object of class \code{onemap}. -#' @param bins an object of class \code{onemap_bin}. -#' -##' @return An object of class \code{onemap}, i.e., a list with the following -##' components: \item{geno}{a matrix with integers indicating the genotypes -##' read for each marker. Each column contains data for a marker and each row -##' represents an individual.} \item{n.ind}{number of individuals.} -##' \item{n.mar}{number of markers.} \item{segr.type}{a vector with the -##' segregation type of each marker, as \code{strings}.} \item{segr.type.num}{a -##' vector with the segregation type of each marker, represented in a -##' simplified manner as integers, i.e. 1 corresponds to markers of type -##' \code{"A"}; 2 corresponds to markers of type \code{"B1.5"}; 3 corresponds -##' to markers of type \code{"B2.6"}; 4 corresponds to markers of type -##' \code{"B3.7"}; 5 corresponds to markers of type \code{"C.8"}; 6 corresponds -##' to markers of type \code{"D1"} and 7 corresponds to markers of type -##' \code{"D2"}. Markers for F2 intercrosses are coded as 1; all other crosses -##' are left as \code{NA}.} \item{input}{the name of the input file.} -##' \item{n.phe}{number of phenotypes.} \item{pheno}{a matrix with phenotypic -##' values. Each column contains data for a trait and each row represents an -##' individual.} \item{error}{matrix containing HMM emission probabilities} -#' -#' -#' @author Marcelo Mollinari, \email{mmollina@@usp.br} -#' @seealso \code{\link[onemap]{find_bins}} -#' @keywords bins dimension reduction -#' @examples -#' -##' data("onemap_example_f2") -##' (bins<-find_bins(onemap_example_f2, exact=FALSE)) -##' onemap_bins <- create_data_bins(onemap_example_f2, bins) -#' -#'@export -create_data_bins <- function(input.obj, bins) -{ - ## checking for correct object - if(!inherits(input.obj,"onemap")) - stop(deparse(substitute(input.obj))," is not an object of class 'onemap'") - - if(!inherits(bins, "onemap_bin")) - stop(deparse(substitute(bins))," is not an object of class 'onemap_bin'") - - if (input.obj$n.mar<2) stop("there must be at least two markers to proceed with analysis") - - nm<-names(input.obj) - dat.temp<-structure(vector(mode="list", length(nm)), class=class(input.obj)) - names(dat.temp)<-nm - wrk<-match(names(bins$bins), colnames(input.obj$geno)) - dat.temp$geno<-input.obj$geno[,wrk] - dat.temp$n.ind<-nrow(dat.temp$geno) - dat.temp$n.mar<-ncol(dat.temp$geno) - dat.temp$segr.type<-input.obj$segr.type[wrk] - dat.temp$segr.type.num<-input.obj$segr.type.num[wrk] - #dat.temp$phase<-input.obj$phase[wrk] - dat.temp$n.phe<-input.obj$n.phe - dat.temp$pheno<-input.obj$pheno - if(!is.null(input.obj$CHROM)) dat.temp$CHROM <- input.obj$CHROM[wrk] - if(!is.null(input.obj$POS)) dat.temp$POS <- input.obj$POS[wrk] - if(!is.null(input.obj$ref_alt_alleles)) dat.temp$ref_alt_alleles <- input.obj$ref_alt_alleles[wrk,] - dat.temp$error <- input.obj$error[wrk + rep(c(0:(input.obj$n.ind-1))*input.obj$n.mar, each=length(wrk)),] - return(dat.temp) -} - -#' Add the redundant markers removed by create_data_bins function -#' -#' @param sequence object of class \code{sequence} -#' @param onemap.obj object of class \code{onemap.obj} before redundant markers were removed -#' @param bins object of class \code{onemap_bin} -#' -##' @return New sequence object of class \code{sequence}, which is a list containing the -##' following components: \item{seq.num}{a \code{vector} containing the -##' (ordered) indices of markers in the sequence, according to the input file.} -##' \item{seq.phases}{a \code{vector} with the linkage phases between markers -##' in the sequence, in corresponding positions. \code{-1} means that there are -##' no defined linkage phases.} \item{seq.rf}{a \code{vector} with the -##' recombination frequencies between markers in the sequence. \code{-1} means -##' that there are no estimated recombination frequencies.} -##' \item{seq.like}{log-likelihood of the corresponding linkage map.} -##' \item{data.name}{object of class \code{onemap} with the raw -##' data.} \item{twopt}{object of class \code{rf_2pts} with the -##' 2-point analyses.} -#' -#' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} -#' -#' @seealso \code{\link[onemap]{find_bins}} -#' -#' @keywords redundants bins -#' -#' @export -add_redundants <- function(sequence, onemap.obj, bins){ - - if(!inherits(sequence, c("sequence"))) stop("Input object must be of class sequence") - if(!inherits(onemap.obj, c("onemap"))) stop("Input object must be of class onemap") - if(!inherits(bins, c("onemap_bin"))) stop("Input object must be of class onemap_bin") - - idx <- match(colnames(sequence$data.name$geno)[sequence$seq.num], names(bins[[1]])) - sizes <- sapply(bins[[1]][idx], function(x) dim(x)[1]) - - mks <- sapply(bins[[1]][idx], rownames) - mks <- do.call(c, mks) - mks.num <- match(mks, colnames(onemap.obj$geno)) - - new.seq.rf <- as.list(cumsum(c(0,sequence$seq.rf))) - - new.phases <- as.list(c(NA, sequence$seq.phases)) - - for(i in 1:length(new.seq.rf)){ - new.seq.rf[[i]] <- rep(new.seq.rf[[i]], each = sizes[i]) - new.phases[[i]] <- rep(new.phases[[i]], each = sizes[i]) - } - - new.seq.rf <- do.call(c, new.seq.rf) - new.phases <- do.call(c, new.phases)[-1] - new.seq.rf <- diff(new.seq.rf) - new_sequence <- sequence - new_sequence$seq.num <- mks.num - new_sequence$seq.phases <- new.phases - new_sequence$seq.rf <- new.seq.rf - new_sequence$data.name <- onemap.obj - new_sequence$probs <- "with redundants" - return(new_sequence) -} - - +####################################################################### +# # +# Package: onemap # +# # +# File: create_dataset_bins.R # +# Contains: select_data_bins add_redundants # +# # +# Written by Marcelo Mollinari with minor changes by Cristiane # +# Taniguti # +# copyright (c) 2015, Marcelo Mollinari # +# # +# First version: 09/2015 # +# License: GNU General Public License version 3 # +# # +####################################################################### + +#' New dataset based on bins +#' +#' Creates a new dataset based on \code{onemap_bin} object +#' +#' Given a \code{onemap_bin} object, +#' creates a new data set where the redundant markers are +#' collapsed into bins and represented by the marker with the lower +#' amount of missing data among those on the bin. +#' +#' @aliases create_data_bins +#' @param input.obj an object of class \code{onemap}. +#' @param bins an object of class \code{onemap_bin}. +#' +##' @return An object of class \code{onemap}, i.e., a list with the following +##' components: \item{geno}{a matrix with integers indicating the genotypes +##' read for each marker. Each column contains data for a marker and each row +##' represents an individual.} \item{n.ind}{number of individuals.} +##' \item{n.mar}{number of markers.} \item{segr.type}{a vector with the +##' segregation type of each marker, as \code{strings}.} \item{segr.type.num}{a +##' vector with the segregation type of each marker, represented in a +##' simplified manner as integers, i.e. 1 corresponds to markers of type +##' \code{"A"}; 2 corresponds to markers of type \code{"B1.5"}; 3 corresponds +##' to markers of type \code{"B2.6"}; 4 corresponds to markers of type +##' \code{"B3.7"}; 5 corresponds to markers of type \code{"C.8"}; 6 corresponds +##' to markers of type \code{"D1"} and 7 corresponds to markers of type +##' \code{"D2"}. Markers for F2 intercrosses are coded as 1; all other crosses +##' are left as \code{NA}.} \item{input}{the name of the input file.} +##' \item{n.phe}{number of phenotypes.} \item{pheno}{a matrix with phenotypic +##' values. Each column contains data for a trait and each row represents an +##' individual.} \item{error}{matrix containing HMM emission probabilities} +#' +#' +#' @author Marcelo Mollinari, \email{mmollina@@usp.br} +#' @seealso \code{\link[onemap]{find_bins}} +#' @keywords bins dimension reduction +#' @examples +#' +##' data("onemap_example_f2") +##' (bins<-find_bins(onemap_example_f2, exact=FALSE)) +##' onemap_bins <- create_data_bins(onemap_example_f2, bins) +#' +#'@export +create_data_bins <- function(input.obj, bins) +{ + ## checking for correct object + if(!inherits(input.obj,"onemap")) + stop(deparse(substitute(input.obj))," is not an object of class 'onemap'") + + if(!inherits(bins, "onemap_bin")) + stop(deparse(substitute(bins))," is not an object of class 'onemap_bin'") + + if (input.obj$n.mar<2) stop("there must be at least two markers to proceed with analysis") + + nm<-names(input.obj) + dat.temp<-structure(vector(mode="list", length(nm)), class=class(input.obj)) + names(dat.temp)<-nm + wrk<-match(names(bins$bins), colnames(input.obj$geno)) + dat.temp$geno<-input.obj$geno[,wrk] + dat.temp$n.ind<-nrow(dat.temp$geno) + dat.temp$n.mar<-ncol(dat.temp$geno) + dat.temp$segr.type<-input.obj$segr.type[wrk] + dat.temp$segr.type.num<-input.obj$segr.type.num[wrk] + #dat.temp$phase<-input.obj$phase[wrk] + dat.temp$n.phe<-input.obj$n.phe + dat.temp$pheno<-input.obj$pheno + if(!is.null(input.obj$CHROM)) dat.temp$CHROM <- input.obj$CHROM[wrk] + if(!is.null(input.obj$POS)) dat.temp$POS <- input.obj$POS[wrk] + if(!is.null(input.obj$ref_alt_alleles)) dat.temp$ref_alt_alleles <- input.obj$ref_alt_alleles[wrk,] + dat.temp$error <- input.obj$error[wrk + rep(c(0:(input.obj$n.ind-1))*input.obj$n.mar, each=length(wrk)),] + return(dat.temp) +} + +#' Add the redundant markers removed by create_data_bins function +#' +#' @param sequence object of class \code{sequence} +#' @param onemap.obj object of class \code{onemap.obj} before redundant markers were removed +#' @param bins object of class \code{onemap_bin} +#' +##' @return New sequence object of class \code{sequence}, which is a list containing the +##' following components: \item{seq.num}{a \code{vector} containing the +##' (ordered) indices of markers in the sequence, according to the input file.} +##' \item{seq.phases}{a \code{vector} with the linkage phases between markers +##' in the sequence, in corresponding positions. \code{-1} means that there are +##' no defined linkage phases.} \item{seq.rf}{a \code{vector} with the +##' recombination frequencies between markers in the sequence. \code{-1} means +##' that there are no estimated recombination frequencies.} +##' \item{seq.like}{log-likelihood of the corresponding linkage map.} +##' \item{data.name}{object of class \code{onemap} with the raw +##' data.} \item{twopt}{object of class \code{rf_2pts} with the +##' 2-point analyses.} +#' +#' @author Cristiane Taniguti, \email{chtaniguti@@tamu.edu} +#' +#' @seealso \code{\link[onemap]{find_bins}} +#' +#' @keywords redundants bins +#' +#' @export +add_redundants <- function(sequence, onemap.obj, bins){ + + if(!inherits(sequence, c("sequence"))) stop("Input object must be of class sequence") + if(!inherits(onemap.obj, c("onemap"))) stop("Input object must be of class onemap") + if(!inherits(bins, c("onemap_bin"))) stop("Input object must be of class onemap_bin") + + idx <- match(colnames(sequence$data.name$geno)[sequence$seq.num], names(bins[[1]])) + sizes <- sapply(bins[[1]][idx], function(x) dim(x)[1]) + + mks <- sapply(bins[[1]][idx], rownames) + mks <- do.call(c, mks) + mks.num <- match(mks, colnames(onemap.obj$geno)) + + new.seq.rf <- as.list(cumsum(c(0,sequence$seq.rf))) + + new.phases <- as.list(c(NA, sequence$seq.phases)) + + for(i in 1:length(new.seq.rf)){ + new.seq.rf[[i]] <- rep(new.seq.rf[[i]], each = sizes[i]) + if(inherits(onemap.obj, c("f2", "outcross", "backcross"))) new.phases[[i]] <- rep(new.phases[[i]], each = sizes[i]) + } + + new.seq.rf <- do.call(c, new.seq.rf) + new.phases <- do.call(c, new.phases)[-1] + new.seq.rf <- diff(new.seq.rf) + new_sequence <- sequence + new_sequence$seq.num <- mks.num + new_sequence$seq.phases <- new.phases + new_sequence$seq.rf <- new.seq.rf + new_sequence$data.name <- onemap.obj + new_sequence$probs <- "with redundants" + return(new_sequence) +} + + diff --git a/R/write_haplotypes.R b/R/write_haplotypes.R index 1890939..b2c3bd9 100644 --- a/R/write_haplotypes.R +++ b/R/write_haplotypes.R @@ -142,6 +142,7 @@ progeny_haplotypes <- function(..., if(length(input) == 0) stop("argument '...' missing, with no default") # Accept list of sequences or list of list of sequences if(inherits(input[[1]], "sequence")) input.map <- input else input.map <- unlist(input, recursive = FALSE) + if(all(input.map[[1]]$probs == "with redundants")) stop("Use the sequences before adding redundants.") if(!all(sapply(input.map, function(x) inherits(x, "sequence")))) stop(paste("Input objects must be of 'sequence' class. \n")) if(is.null(group_names)) group_names <- paste("Group",seq(input.map), sep = " - ") n.mar <- sapply(input.map, function(x) length(x$seq.num)) From 4e05a24dc6ebdad2953855a051567b88f4fa914b Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Mon, 16 Oct 2023 10:24:22 -0500 Subject: [PATCH 29/36] remove warnings --- R/onemap_read_vcfR.R | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/R/onemap_read_vcfR.R b/R/onemap_read_vcfR.R index 1096756..21c518e 100644 --- a/R/onemap_read_vcfR.R +++ b/R/onemap_read_vcfR.R @@ -156,6 +156,8 @@ onemap_read_vcfR <- function(vcf=NULL, if(phased) GT_matrix <- gsub("[|]", "/", as.matrix(GT_matrix)) + GT_names <- names(table(GT_matrix)) + GT_names_up <- strsplit(GT_names, "/") max.alleles <- max(as.numeric(do.call(c, GT_names_up[-1]))) @@ -171,10 +173,12 @@ onemap_read_vcfR <- function(vcf=NULL, GT_names_up[idx.mis] <- "./." only_diff <- which(GT_names_up != GT_names) - repl <- GT_names_up[only_diff] - sear <- GT_names[only_diff] - for(i in 1:length(sear)){ - GT_matrix[which(GT_matrix == sear[i])] <- repl[i] + if(length(only_diff) > 0){ + repl <- GT_names_up[only_diff] + sear <- GT_names[only_diff] + for(i in 1:length(sear)){ + GT_matrix[which(GT_matrix == sear[i])] <- repl[i] + } } } @@ -205,10 +209,16 @@ onemap_read_vcfR <- function(vcf=NULL, P2_1 <- sapply(strsplit(GT_matrix[,P2], "/"), "[", 1) P2_2 <- sapply(strsplit(GT_matrix[,P2], "/"), "[", 2) - P1_1_allele <- unlist(Map("[",alleles,as.numeric(P1_1) + 1)) - P1_2_allele <- unlist(Map("[",alleles,as.numeric(P1_2) + 1)) - P2_1_allele <- unlist(Map("[",alleles,as.numeric(P2_1) + 1)) - P2_2_allele <- unlist(Map("[",alleles,as.numeric(P2_2) + 1)) + # avoid warning + P1_1_t <- gsub("[.]", NA, P1_1) + P1_2_t <- gsub("[.]", NA, P1_2) + P2_1_t <- gsub("[.]", NA, P2_1) + P2_2_t <- gsub("[.]", NA, P2_2) + + P1_1_allele <- unlist(Map("[",alleles,as.numeric(P1_1_t) + 1)) + P1_2_allele <- unlist(Map("[",alleles,as.numeric(P1_2_t) + 1)) + P2_1_allele <- unlist(Map("[",alleles,as.numeric(P2_1_t) + 1)) + P2_2_allele <- unlist(Map("[",alleles,as.numeric(P2_2_t) + 1)) names(P1_1_allele) <- names(P1_2_allele) <- names(P2_1_allele) <- names(P2_2_allele) <- rownames(GT_matrix) From c8ffc56b43663635eca35d8fac79a29b5e3b21d9 Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Mon, 16 Oct 2023 10:36:27 -0500 Subject: [PATCH 30/36] up version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index fbccc39..66e5be4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: onemap Title: Construction of Genetic Maps in Experimental Crosses -Version: 3.1.0 +Version: 3.1.1 Description: Analysis of molecular marker data from model (backcrosses, F2 and recombinant inbred lines) and non-model systems (i. e. outcrossing species). For the later, it allows statistical From 06691379c067e6a9ea576beb5952874f64c4872b Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Thu, 26 Oct 2023 10:32:16 -0500 Subject: [PATCH 31/36] bugfix --- R/find_bins.R | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/R/find_bins.R b/R/find_bins.R index 316869b..7311a25 100644 --- a/R/find_bins.R +++ b/R/find_bins.R @@ -55,27 +55,25 @@ find_bins <- function(input.obj, exact=TRUE) if (input.obj$n.mar<2) stop("there must be at least two markers to proceed with analysis") - if(exact==TRUE){ + if(exact){ temp_geno <- as.data.frame(t(input.obj$geno)) temp <- temp_geno %>% group_by_all() %>% dplyr::mutate(label = cur_group_id()) - - bin <- vector() - j <- 1 - for(i in 1:length(temp$label)){ - if(i == 1){ - bin[i] <- 1 - } else if(temp$label[i] != temp$label[i-1]) { - bin[i] <- j+1 - j <- j + 1 - } else { - bin[i] <- j - } - } + bin <- temp$label + mis<-apply(input.obj$geno,2, function(x) 100*sum(x==0)/length(x)) + dtf<-data.frame(bin, mis) + # Recover initial ordering + dtf_temp <- split.data.frame(dtf, dtf$bin) + dtf_temp <- dtf_temp[match(unique(bin), names(dtf_temp))] + for(i in 1:length(dtf_temp)) + dtf_temp[[i]]$bin <- i + names(dtf_temp) <- NULL + dtf <- do.call(rbind, dtf_temp) } else { bin<-get_bins(input.obj$geno, exact) + mis<-apply(input.obj$geno,2, function(x) 100*sum(x==0)/length(x)) + dtf<-data.frame(bin, mis) } - mis<-apply(input.obj$geno,2, function(x) 100*sum(x==0)/length(x)) - dtf<-data.frame(bin, mis) + w<-by(dtf, dtf$bin, function(x) x) names(w)<-sapply(w, function(x) rownames(x)[which.min(x$mis)]) structure(list(bins=w,info=list(n.ind=input.obj$n.ind, n.mar=input.obj$n.mar, exact.search=exact)), class="onemap_bin") From f72488d7252642acb2d335a05543e88668c75fe8 Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Thu, 26 Oct 2023 10:40:10 -0500 Subject: [PATCH 32/36] up version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 66e5be4..fc2b9f6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: onemap Title: Construction of Genetic Maps in Experimental Crosses -Version: 3.1.1 +Version: 3.1.2 Description: Analysis of molecular marker data from model (backcrosses, F2 and recombinant inbred lines) and non-model systems (i. e. outcrossing species). For the later, it allows statistical From d85ef3fbb95aa75dc464f2cf9e8e00f04a15b26d Mon Sep 17 00:00:00 2001 From: cristianetaniguti Date: Fri, 27 Oct 2023 13:39:26 -0500 Subject: [PATCH 33/36] update paper --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index d12d383..98764da 100644 --- a/README.md +++ b/README.md @@ -112,7 +112,7 @@ Margarido, G. R. A., Souza, A. P., &38; Garcia, A. A. F. (2007). OneMap: softwar * If you are using OneMap versions > 2.0, please cite also: -[Taniguti, C. H.; Taniguti, L. M.; Amadeu, R. R.; Lau, J.; de Siqueira Gesteira, G.; Oliveira, T. de P.; Ferreira, G. C.; Pereira, G. da S.; Byrne, D.; Mollinari, M.; Riera-Lizarazu, O.; Garcia, A. A. F. Developing best practices for genotyping-by-sequencing analysis using linkage maps as benchmarks. BioRxiv. https://doi.org/10.1101/2022.11.24.517847](https://www.biorxiv.org/content/10.1101/2022.11.24.517847v3) +Taniguti, C. H.; Taniguti, L. M.; Amadeu, R. R.; Lau, J.; de Siqueira Gesteira, G.; Oliveira, T. de P.; Ferreira, G. C.; Pereira, G. da S.; Byrne, D.; Mollinari, M.; Riera-Lizarazu, O.; Garcia, A. A. F. Developing best practices for genotyping-by-sequencing analysis in the construction of linkage maps. GigaScience, 12, giad092. https://doi.org/10.1093/gigascience/giad092 * If you used the HMM parallelization, please cite [BatchMap](https://github.com/bschiffthaler/BatchMap) paper too: From 15708c7178f1e83857946cf0f8a37ad1957dc7d0 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Wed, 27 Dec 2023 15:50:45 -0600 Subject: [PATCH 34/36] up vig --- R/export_functions.R | 28 ++++++-- data/LG3_comp.RData | Bin 91804 -> 0 bytes vignettes/Outcrossing_Populations.Rmd | 95 +++++++++++++++++++------- 3 files changed, 93 insertions(+), 30 deletions(-) delete mode 100644 data/LG3_comp.RData diff --git a/R/export_functions.R b/R/export_functions.R index 2d2a36f..6c3ca75 100644 --- a/R/export_functions.R +++ b/R/export_functions.R @@ -14,12 +14,30 @@ export_viewpoly <- function(seqs.list){ # only for biallelic markers types <- seqs.list[[i]]$data.name$segr.type[seqs.list[[i]]$seq.num] if(inherits(seqs.list[[i]]$data.name, "outcross")){ - labs.p1 <- c("B3.7"=1, "D1.10" = 1, "D2.15" = 0) - labs.p2 <- c("B3.7"=1, "D1.10" = 0, "D2.15" = 1) - d.p1[[i]] <- labs.p1[match(types, names(labs.p1))] - d.p2[[i]] <- labs.p2[match(types, names(labs.p2))] + labs.out <- c("A.1" = 1, + "A.2" = 2, + "A.3" = 3, + "A.4" = 4, + "B1.5" = 5, + "B1.6" = 6, + "B3.7"=7, + "C.8" = 8, + "D1.9" = 9, + "D1.10" = 10, + "D1.11" = 11, + "D1.12" = 12, + "D1.13" = 13, + "D2.14" = 14, + "D2.15" = 15, + "D2.16" = 16, + "D2.17" = 17, + "D2.18" = 18) + d.p1[[i]] <- labs.out[match(types, names(labs.out))] + d.p2[[i]] <- labs.out[match(types, names(labs.out))] } else if(inherits(seqs.list[[i]]$data.name, "intercross")){ - labs <- c("A.H.B" = 1) + labs <- c("A.H.B" = 1, + "C.A" = 2, + "D.B" = 3) d.p1[[i]] <- labs[match(types, names(labs))] d.p2[[i]] <- labs[match(types, names(labs))] } else if(inherits(seqs.list[[i]]$data.name, "backcross")){ diff --git a/data/LG3_comp.RData b/data/LG3_comp.RData deleted file mode 100644 index 4c9ff50dae3b106733f3e1af52269440e18e5837..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 91804 zcmZs?eOMD`zCV1<>D9yO`m6kU{8?HNvgf#`Y-^QT)ChrOTX*ZzrIOY+gg{b@ii#4` z5JO()w60}ag`BQcL`c#uMMMaZB8Hc|thFX8BoTo`49O_b1Q^H=hRNh@W}eyeJpVk; zb@IntbKO^Fa=(1<&-e5FeD2WB{>wl7_vfGIO)vHT$A={WVCd-gB^zG-$5+0+^J3qL zg!$XoU)gbM?AQPP>tEmhZU4xxfA!`4zkdHhLG|~o{;TW!@A|(?{OYrz_3ym9@9CFc z{`&Os&|hz?xO??#D^dOg=yVhWe{bX;0(id<=-yIy1m9eeTh6~8JN$cj;j^zdGDBae zUNXo>Hl(gxS^fFRJBN0VvawcG3O(`X9hsl~a_iRWMp{W@Mw#H`*;fCB)Wp@rM{MBn zZf0=i24n3cowcn$xpfDR^>hYF$skQ*VX&E<#J^9E$&l&V_UY(*2Zf0Z^QTu#<)|IctPPvhtB?F?_9Y&ssAey9bE4esu=1Z(_``E z-mdU1VOwh~OJ;FiYT|q3ksM~MK5;QVtPEJzg7dr5Ud&& z{z`lGGi+xj*~HFOj`VI@d;H2%hHAu>!dTgiwz7{5Jb!pe}pzw%AaYU zh|QnkLdz*UmAJjY{2V_=GvURS#jv=XpoZXS9eLXY!H*JYl zvb0^JMmpBWO;Imw>XC7=fOBX-qmS-a@QQXn4NsQgEkv&2+EgjUbw4U zrL-k@7GfSI?=CK52?B+xk)z_=YiAXW*NKAr+omTsFNYhJv!&W-8WoRKd$i(l;G=sw#-TO%!8^74; zQwBXc=hX5y*_PWN^SB~j4FkbCGq~O5_8WY-qu2<>MclXm%mCF*6D1F>SjX#rG2E1@(NrevYtIHO;oX_jbpyJjhx*5yn-PAixz z>MZWI%vtb}G~!mH5*o$HC+}%Lhgtiz1hE50hnewq7ccyw1^qcY(*@-`%>=~JC)tdL z$R!T>tkUH9#8Nh3#(JxPA0b>{`^yT;r|p0&UpUq*_q0zXX)b+o9+Sq$GMBESjctJV zIhh2tH9sa4G{FLgH=rDqd7t&M!hdsj1Jhimkz8kQo z+}&&z4w+};J1ocWFUcCb)d!6fuT=woi2j)-9gR1!BCBYm-;LjjBick*EQi`zQU#u+ zAkOnX*SBj6V6eQ8Kv9(iI*~0I2b5=KVgr?O^aMZlGq2S0j7Y`RwyD_*P!845=#6b^ z)B&NJ;(ps)Hfwq&ZXvr<3SwKK9CqxgCH6#Ia1!536I!&=F_1f?yi>tURBLOS0j}k# z$9xQZz%wtz>p}bxKY61V2*qCpoA|ZiM!+Ahw=B9rk<;xxfq%tQj8%c*o6X(eqFY}( zY%^k2Zl`SC!(EEEms^y+0yDY^Ohjxg1x&)rUHTh}WG;=+YF#NNPu#7=cUZzZ;P5Xf zq*=~jC%}#}eKGqqlg`@!;Comn_sz=d~<-Ls#5N(Q8@0g$o8?smcY4#$dwBupBZGD7_4D0{x*g5YOWE`x0X`l(?{h-`FsgHaa2uH8r|aciS|emgmaok1aA^rvFuERkK#BmWJE zE_L#v0}vg5rn5X}5Kr4(`o!I#0{<8*k^w>R(s;A{Sq^Aa`cD({EFO`;FSE>k4abrs zQV1B8&s#zG44W9@? zxLClIfz++tOT*W@Eminm0HIzlwXlhHv{1RMR^`d>3teu@OpYc3KJ=&>*ixjC>1VrH zL>8GKSn-?LJj?PDPl1u~uSxu_GJ$3jSJzqO;qAQG-7uz_w+v2;8qZKKLq=)Q-CAU4 z<$@|Y&z9ofYQkX_c2i7+XxPn7Jm_`fj!s_UB?z+kom#wE&ze*52c2%>=OF-_M98>5 z^d}UJDM{!IZ>a-HO9n0dcWBD#lrG*dhFmkqj`_s<9-? z>~Ck);$H@d5ixnM0Q|{JtR|l~^5REXH8pZyDl1H<^$;{TGRQE6f2wk4N3W$yY?uim zcI2_5gDE6&0ZPNCb6{m)-0LF!kY&lIjc(C%ElZO~g|;12NkOoI3^a%t;xcXgnb5{gg0vx`o(Fg;_1yR$ zAbL58Ie`fUQ-oi!0K>O^r<}AB(v^6EaSeGU;wez;aN}CH7oLe8D)t7_EkZo0H!W$E zv9rVxJV_GIXhVrgvlKU`l*dMjla37(p!||W&JLRs*HAHW{{j$ghmFqB7%%>iqjXhj z`bdwVUSGn3KcV$YVRAsHVmP5nl?38+Zt@H~xS%f} zW|VBAfyY1=pdc{QO1Ld#kE)ynUvvAg+scLQDo284!R`i=&*D1)jKsYezTh7!okMrr z3e4kjlGot`&XNDZaOufwtbUu5oW~n92~}w6PicTRZYaW+DwB7%D+9l+o`Ne`$eZrW z4A$I-2Ft(E%CQm_(aWm^Q9f5<*wLblr8{Tk%Nw|YaR*P1*yOV*-8_;-E;4*cU9sK* z`Dj$2c2b0;90nE=z`c~@-Hj_V??tCT06o3c)|m7NZ6K~r^{r)LhONl~w&xKX_U(|& zxizs?IQFy>L2ZBo^HwPWLNf9uiH<4xia;(vbdACN-uR2z(n$k8O2^{^{t1?tN>x>4 zV5bH7YjZ|y(r@D_XH0H4E5x=WHff~`@px82ZqmW`iSREQpJlbNi0i#U7Od4Si-Ysw z_2!cbyfPnK$0NV0R}5uk+Hbp)byxyV5M#NC`|V_~zPppxm#bW?Q~T?(Sxf#@Nu<&2 zO!bNt_!d67$SEgZ3PumnB59SV58azR&WDFGto?ChLXIz02URiu66oEyN2zMVG7*1fPB282Xaf*de=STE8}Uo*#R$rz}=C(*&9wOX8BVD{)q{~1?5~fIDkyhg3DRGVutz!uSB>);pm5*kT(@mAQ zUBO>EZK!=t-QKngEYU+)e~wccJR4F%W5wEm&=RPC*hHk)Q6_$F0Ve2pm`}Ct!{n-F z1+v{yhE=l%y{1qyn&Vc-+t||QVx6;0oH)(HFU!2i5s_H_NKf2jmC0(7_biH^+i|oB z3N4>!%N|XD%D^DjkDd-Ki^Z%wW~|e{9X=Tt95Um(&9Mq4L_I8fnwrGuNrZZaP>_Lp zB=S|OpQngd;^^OhMg=H|Y^A4}x^=>`hy3TXWos2c3MGGwn={yIh2TmOudjkBExF z@Hjm`3^gAdeMQILqkr zJ0P)`!;=IC!(Y=)w};8_h$xm|`q5N!F~_YlKh=o`kBcJF;#BkVZ}9^FvIy6zAZnt) zl&Qs5IMG|#omf;!Y==nnN@X{PwIK7w3sb2M^l6m~>p;u>nQogQ34~xLz>1z8!elQA|d&r!TYvXfqH? zwJbkQ(-J&!?X46p65fV$vZG&dOfifrj;H#9NG93`;EQAQCQH^#r=g&|*K!D^dD2c@zsMZbH3U8JoR;*D56U>>5ti|h9MHXbruXN3d z@kawGxp=oFS)Y=L-fKFYy3Mme#SktI(LQ&>$$?7E!2GG(tNF4S_q>W+H~=OeHRIl< zVdawpw53D5#RoZ!;PW1O!o!z8Xc~5&8tb$mBhPvGZLJK_M&Zhhh=G?D<8 zuxH0^q^Tv3ghaBK410liRQ#Wu6Wo9IhQD=Zs>Ys$?;{Ax(~!mtZGVIF{HZq{HzImt z7&+6Mxm}ByU8D0^dSy^?B~&@5esIX^?A#sK_s~kRXePvQ+35>jw^oH}rOsfY#Q#uc z#t5OlYGOg5aUn9%ac8eX8}|+RWaXVJp+Q%~1Ue_+g~qmks?9kFj-y<)E4Eu|v<(P; z#LT<%t{jI3ec_)R&4cVJ{Habm67=1aedAy~&;OkHBm6v8G#cA2x^TYPzvYwcBJ}(+ zy&%=VD#bR(>9YBZmCx$AWRD}qz5b%_O@%|$AS$o&T|Vw?2D&0|)bs^T4}|X> z(-#|xEBRgzhb4b zW`5L?jWyRQt9(VS7gJVYxm&{ccrx-iEF0M!WEDAzhf}YFf+pV@RwpkV&e;;O$3&l% zjr7ZpeaZ13pE&Kqy4xM3>5)s)ezjbwX^MO}QNBBfV7sxNT0OI~0PZmm$W2H`m!f@h zvnLFVhPj9}Js0>Hlp&61G1uV32MiH-4>^}VQQp4B!YjpHEjAO@bOapKit(wq+=M*l zq-?R}`o-@t^+U=>k5f)y&DXMw_-Ea_qvkG8ExRIszDcSdJV##`bG}@lgH0n+6%4!+ z#yjFO-RyHzc54cACknJ(=)tL8#D`GRw_~(F1jl7}u-oAE#gBDsZ_F*6uwas+Yubz7 zkV2U6t(;Tp`RwqUhNFj8VKc6xjxWP=)+3uowJc) z7xsYz)lFz*%GZ%Yr!pSInbth`Nz&$$jOT@h66$wrMzN)`_Uf`aG*c;Nf|d7unW=NF zQ{;DH{8ntiD>!D(1v{H1!uPdJ^mB;;tYeJ@+izKS$^Ub3RCtNlI?=s}9Ko(!jZXBH>Q+put(`>9RK$QlPe{xl3yUkH`V8*cW(xQ zKic!saa&8{iddbSECt8HlHJI?@j|)Sw})gv2lbSEIp5xa{4b`6%V(rGkSmXcZsA2* zI-&Sm@Dm_p)^2lhu#bG=zbXi`nJxBJnORRYhALF-Cx65%0Z8-9C$yBxPY4F7VhQRQKolzAT38d1^n z7h}pf`7||0i``?d>h*8b+(lOeQ>*fgP;RF}>}8A+w{FFp&CTSqgjMvfGy`zaLF1B_ z=28i>p<%V2@YinktW%ym=?8~w=h31Y3=iv#$GN|* zwnElKsp$85;9vM_odd+EF|(yvyg^}tUu+?!^7sZoiVVy;i!xl{|BUS-Htl79bYs|k zf_z)eGWs9Q(E{gQtK1Bc3|h};-dxW3=wxT6W~h2;ZYr}R_~G+Z$m~O}Pq2Kj zX@_eFA1ftqxJ1XEJA=<>tdiO{%YpUfA_5#j$hsmtp+)#OA~ z1Il;qlsG?3*!D2?C3Y`t@Ma64zSCdBro1a=zB;uqv4c;3)HiIL$d*B?p~Tq*8aHEi zaOdphLH!*{ewj+%vc2$=EZB+`KsS~oeC9#NLXiSYPiuGZCkFbcH^*$_3S*uT^CSHV zNUmpTZvZ2@ENaOrF+Ps&^vb^MigtMP)}k1;|i`5}3` zzj{uY)@eS57a+VU#hu_nC`Z7GDW{o%1TaYa=lt1yJW;$ZH&Y$+KY8-aaO%p9fP1vg zvlcIi%NL`qmfK&^%1)iUb8ACGLot)c(JqbK3ZB2@+!mMD`H>(H|e)ZTsY{-*x;$ z+dqBxtB?P`H(!4I*1xpYlp-P-@w zYlSaXbbR{u>T_*h_Uw7*;;;U@@y~5v?tklly8K^lU+#J9f4bal`?Bn<|LL;-!mswV zeYv;e)4gx~|86-i(iv&rcIP&H?KzwcM4yIMozngs8Y7GX?9C9f&D(BF+%SPVGtFm# z9kf)8)^UI^YB-=_xk_aIMjdYPHSfP z?(ONEZ=63w^Iz3ggmYJGg<%O@;J69wJi7McKmT#vch-;B^laXB^x4n9lhD4y-ur(p z+Ez#Yw%XvWH+J$)UH@>*<9uPKX?^DZ?)H5s`E|FiQ1ayIM504LcGe;4-xRBY`1IAb zs{6gy3a5$8p`%N$6jz#Z&OUni@e3zKqj#$_^PeoveIgJ!|5z$;?;?JW1UKG^{kR(6 zXAmA$bZhVrtiy+*db#-|1V3);8J&#b>H>wc=|`zy^Qd277L{l~+xCG!I#E+t;U<@khkW0%o(NtQ`-w`TdCu8ciwp*8N3ufeh6&_bTV%&8AlI;8hFP8j-g-&Mbfq4g69HI>clK}Av57SSuLh;vwM44>Z?^oX*V7YzJ z-b&IKf6SrL_@WV5a2$l9$)V~6er_Vj(VG&R01B!2l!!K}fIkd^iGDRB(=b#3uk=8( z$)QYxSmlRq#$kyZ-v<{^Gi6vnGPD+4*_q(hOx+Z>S5OvH&|=#JaxslOql9|{5Xh2V?`M}+rkOdd)5IKWY-TzB(QRXuaHm8 zJ&Gh2R4R|M-xF4pfTxnxJ3+qQ6B$$A9K0#LXHJ>)#7>Im^b7Jw4(9@HaP}!evfV6` zQ$VGM>H7JdDqm$LW`7UG)U&v3Lb%+==)>J_(FyEP2rZ@lVxo@6!<=hc#aKblSy zvh%B9N3&l~DOw5lFMfaUL<0$Ff{$6-f=4Ue#WdMMorQpb_#u;#zA+UJ1x#{ zkGqHO_%xQLxsbXhEpfy#{1U5)!MsTO$lmG-7aRq)btG#2-_gw_gLVm1bYpoN+*>Pe zUShY>>=Cu#ZyDKCr8UChlA97^vtll}P;k>Ht|r29&$H+n<))b2Y7EEQmfipHm*PM` z8wk&z695_#M7VA=GAUf?CuCJ2e)Nt&&7XP(|9K#IE*iFu^X-(ACUd{ z-3Ou{Ai9_kG|2cF({`3CS}QUHJU-MpMQEY4P|`b>odZEW!6q&Ar#Waq&`DSJ#o164 z3oHb}Jq~S2d-jF)q7j}teCJw^sBW|8bxi8qpU%Cw*|*5KyUbuK`Ql*CZ7$_8oyr)~)6Hmuvy7b8oiECxEk~-Lq`JVl z2EQ_q&3+7AoYSt@3)*#Q(qLT^u*Oz-la%<`!T5L=oDQW_l{K!R?I!zaOIqRP8%j~;*a-RcE;4NH@5iw1(sa)4Og8@c&atds(jp~?!U+^@<3+DYuCu^a9>D}0? z!T$ALA{76=N121{3Cg}WObWUyy%KP#a($}3{S0OY-u+(pYpRRaz*0md_AR^ICSt50 zwIz0{+UqR?C4PC8X|_woLGXvfLp5C;`##sQ&0j|c_A6)XZlCBFEE3|jV>VA}AH?H=4b}yiauJyFSXgu**LOk#qwvUsLJFW*m%@I zu9#r=`oAA#2@&=4Y@z@0RMeHn)DdIzdbNNO40&Cdo2=rVxP4Z?TR`&e_lTHH==caV zsA8RnhsojP+XHCRgkvgs?9LCa@Fr;PjJw?qvG@$N6V|mFk#TjF(LXlRo>nCf#H;wm zBf9K2kjat!L-n?Y1Xx;kGyX}HymxM~BQ}k$fa4?I2u=9dn#NLGPlxwAM;Q$!foL{7 z>qzAI!Cn5(m~}bqTIBsIUvoMrh3J_4W?*dG*i@_fH1LlV>ZiDm!PF_edDXpc{%++& z+_+*QUFUyPYS@o{VE}Xx2X}L9G9z%`dP0!P-7R zgecA)tq#zJLtWry=uj5l0baD^C3^dm%^Y@(`>Y!G6|8j0t4C6*$)+{5hKd{*wzER{ zv*Rp-5^bnYJehYm`WP!h-Ig3H_#tZG^5m!kcjPUnj*gOvgEJpQTCkv0r+yI{yTE zexD_GHX5)4hrMIlm|Rkz;sv84c7|QV^(X$N7c`<8F$FpehCm@KJI}RzuCl!^s{8x? zJKF}mAf7V*4&4v;UlQ0#=p*%f9b(*KE?IDBY_3{Hu$T&;ZpdD#3%A7-|JCa=?zgr1 zTlUgw{mrZ4uEARcR5be)z@}a^q_&0nr>W-!<0U*NsvU^6PiCK!yuDS&zv$R43>w_d zDan9PJ`@}>(A1(Mof~^;d7{fAlR)!&oi6sNF30F}4>V|6R60>pPQw6B{JYAzOF3HV zw4Wt0l-6#g$cxC-v)uwqXv? zH-}nRAu@i!Ts_~qZL7`i2w$H&h()*Iwq}0OH6^6jc%Jtp*;7-dUds-~OoBcUK5eh_ z62hPTy_YoB_}`3XfqFD=WeDwX^YZYHEu_fiaiP;A$qKJCgQbhgdNA4MOkLj13APOS z6pKH+MoRs6-;dq92Bmct2dsz#?O>4GY{)Oxd%5J4#8;Aq27<2m(Q5qgoVtk>u)fj> zj40>Jfb2dZJaZQu8~rjtHkX9$1;85IwH$PXw{^rj1l|X0Ql?_V9-c0Ci=*0) zzE??Jay~7?&`2SY*VDs18RP{Af8p>98c^0kWjx8l%lr?@A2U>?!2vo=ip+f$K6qGh zVs2j7%Rm6W9Et3%Vo9L|S9CLjkGhb38HbiFBG5J1wPoeTy*w<(_Y0K5&%QgI`>#Q`~lxrQ9F z9ryul%*~b|ojFvH{`p=|yG<`CpPaGyBsm7|al6wbz3ewW1w!E`k?e1=tvV7v$~T51 z`U^WaP9zTPlGqp^2PqU!ojAwWp?z+P6o1&Y?y%Kx{+rXT{Hl677e6n!SE9dZ1*tH_ z`fsoz4pl&OxD~u4v6gCg&RQPD4*rlFYcG zp6ntt<;A(~6fsAbQ5ef49Lo!rCW4saI86{XXemW#+eA z^hR|2!-*7EZ4+YX;T}h6RdU&YA+#w7k4VOv`6mC^JiR`A@)R>vP-IkzoE~dffB{v+ z&AE5=WXs2RpuYX=om&q1LMRnZYL3{_EvDGRbKCc2RvFC(=8;UNqt+ECq@lz=^QZD> zrEafwMZK!nHYFXA@}FdC&-k0^D>pD3)S|QEf~h%HweNCqb{ONkk}dP8!MH^%mm;6* z$>qS)Hotu;dYIWrCr?pKPC9Xad*h$U8`fLCxIG>8qS{SNd)VFy|5Lqcf>o$zn~3oY zeM?NYg;g{+^vF`TF_}0jHa*e3@HXpm!u;7&j2}Qf*o*2|7bBH{sOaVmdo6Pa#@LORF4L=TSna-~Pu9|sodeSL zhlkbt%1A4xF-Nn-vLp9txT@ami~o(o+hW0*OL$V`7{A<`-;nixz`@|a1==~vvHzr# z+)o(C``=y-mWukiv!u8#A+Ks-NAV+&oXTua{$ilj*FU%ir@WCBNoBhT_iJb?Oh8q` zm;>YM;MAh~Kq)f!EczgRcsATrPRqro&T(?U)EZ}HrQ-USAwyL}E(Ol};?in45`cWk zu{>tlG3F(~!8t`k4hyr=;pnoJCsy*$HJ_K}L52bJcS17Pzq`{SON2kOupwOGkaC6j z#@O%-7|6T-P2~zV-yR;m463D4yuGg*UdR$p<^B*K6v?ITuq(;esWy&BH`~awo0+}1 z^Qzt(Zl#-FpE{TF0shcSQ`^pWry9ep2JR75>*{~7M%%1)mNafGpuK^hBhkZwubbf1 zfTO)_sc$t{ndrn!YGDQola%_Kw^#yJoiF-^b0_@D#c%jJ;*fRNiZQq(l`?(Jsihzf zbEO25tRLc^Uc-IiCF>nZ{#>rCR4=HVc4YWQ(`@Wn<8XnB6mkF?xiW5U=3^BeE8eH2C*XB5g#<$Qfmr+l!MOuObTO$a(_ zXBEJcKCk4jLc-atEs7@Y_4A+o<5;#DqVW}@YuKD18;))cUa*F*TaQK*Enz!Dxz8d) zIKpx|V%jd0hvekpxjDIh&Yr4^9jsP7L5I#}k}WYCq&I~r?&#__I3U+H*bb$|A2FzO zH23#(IJ!pFcsY0;0iI&+P(G8+a*R;S?i5v3CMXaqxZg ziy>}vlin`ZO6G-N$IYh36Dom;7$ul7-FT5BTS{d?V`a)Zsm*_S5Vj0~e=c9|y3KNokFr)&dx zhCt^&a^U0G{c?j8y4Mu5HN&Oa&WY^o8fw2xx&$Y5;7G0C-t5@sn`5U9YMO_*r`%uc zQ*66nFp65~tUR|R?V3^;e5n(7wOh}Aivnv;5!u4v+C^Voa58M|BI9Mh#hu*(i!a`1 z^{QObGiOYJK|Ddo;*zJC`ImMCm z*VE4{D`ThW)!AjNEpE;V{f-gH2p8v36)iw-kO|Amew%sI#iy8#SiaC@>ypeasLoy# zp9?po2c^(y*S4qj;!u9h1voEgF9S;N14f7jCu{U{qo5NtHT*z+24nl@K$X}=v5Q7= zJ_m27`_#+v8$%nb=k){FQIsZ}N{5EqtoIlcS7OVUQSjH^NVZWsIRsQ@R7A8w ziZZ|yT%`W#m%=$i?>+)192}hl?%uaHJw|FSIx%1?*pX% zy)bTyeZNI7NmPY|H>`zx#e)L4G0(9~gXNkG!y0G}pL-)z87F^6n_|foCi?Yh4uo@{ zpIpfU@k11!4H>Ky9ty5Zvex(up(NdQh(aVfZ2%DmsY)LWq^#F$1)Z0RUA29IiY&VS z-p_EV@#Y2g6yl2+Low;MORAF85glei$6x%0??e0dvNm{0SBwgx0*5bteUn*&BzK|j zLD9GOW_@J6(1gB+CDyGomnaWdvnq!UTgvCLEoxXi6`ROqy5w+uU0R;c5KrvFX6yAK z>8)?*YUnq;mcs!Wp8{PnfZ5bx>p6Wr+Sf70v1D&%dMPvD?eBmoIOSa8vOlCw)uI33 zq-qxSs}9x`?S>o7zUd2eZ4)%n6xN}G=cT}>^~F#ulz(8H?~C7B9$WE$z>C-DZ`dYg z*`}CteDYD~PB%D$zUPmRb7-|e!-edwaLJ&rY>;gBltgh3AD`)7Rd4h?21ES=A19Ax z!mA>*^%`~qrxmQV*)vkJKPP52JjY;V$F`^HU?}Q+J)1JsrqECPvR?+!FJ8w={f8@X zzq+z;_E^2=>_oaX9}Tp+D1hkieULETNen~44aa;rmEru6W(PK6B67s}uj;E_Raz<> z5EoeTIiYM5WNwlU`X9WHwB;6wU9W_qp{`V;$hHgjqhoE*+c_Igb+d<{x7IUj0^v66 z9R~9-x!JWLB*_zctDblG(21$&%||_3cm`LxLr$kV9pz*{YcFD!N!sDFOS_pI* zsW@w#X8EF94a%x|*q0x&vwZP81r&llx=dcSc?XE5wQg(P@MT!%udp_r#bq-;TeMQ> zMKPIc^RA)s^Q+YD!eC?&L`4D?E=$pHg7Eb!OUguzWPCywSHY$EF(vijFCyy95sk_${z$O1UtyDiB?R z=qAC+%tps53O?)4?jyox){zOt57VBhSSX}Dg5xy?q*r zv)wPR+iY!i$z7aw)Rk6f0)#w^DfF)ry(H5 z(}_#ypXl6ei1W-feWh*8m*>u9nvkKrT2u+|qR~2;M@-tuR1VF47YK#wf@nm{Gi5JAMPF~ zg1P|XDJWX&uY{82Z#l$HvI#|}6CL99vn9SgeIG?~$L-(WGvhPjEz+ zW{lYuQtSO=Ysg@vSuEey&_`8R@`-+?*!FKQQo4}68Suue>F}#k)||$<3U{ls*4S+6 zWEyhT5kD}CG4`$9goqX4_#dRj_+R7Q-_CQ=8GymAjJek0LM!#Te z9686Q((`%A@xyWm)$X%g%1EuWX6H1tJV=c013q{1D>NKLzXcdUSMlYL4xGYJvvyO! zHYML8mXE}QJy`nIOcP?5(3%8y86*c}Nl=6Jy)kXkHglhKC=lH?L2=woiK;-f20Ncq zjX6@p#Pxups{Hf!MV+~+d5KnZph(KyA8Th+k94Ju7>#=h0%g=+98Ojxu8{bOv;0DP zyDQA>h;A)u+``oNDVH3WOG1gnA>}1mjjJ&00&GOfswge*?+ernOd*QHrv7pHO>1TK z-^Vl%3;s9t`4_0ET3`!#JT z)XgPNTGBp`J0JRmyKI4EP!4?RYO_Y^P}MoV9e(*`ywJ@rtk-&I>e#0p$+5NKJVYfS zSFNGJ@pg%C8`9S?JV`CaiQo(=KG=tt>>-DEmWKbJyX~PQ?MELFSl~ZvM%z~2rY-p{XQx9Vd>kw z;u@RVic#9A_y;QJl{1-jE@`Jgea!koEA#pin{RHS76j2Um^ChUVNgqfzc1R~oBgeV zCM5BwD|P_YikZuC=TywHM|rHCEVO&tT|_{$jz9054nY?{xnvF7|p-;@vyjxQOyaDGy&4!39%CEuBeOv z6nTo`GxG^C(>X;|0}YoZNgdw1$2iZW%=BJkcq(IjItmY6cZzza_8|0z7KnN*vR}L38sSq2appg zfj3n5hqndl*}E4cxM`Ai#r3jP@VR+o-^#Gd>4@cTVcO9@3ze6`RQaVpnqTUFd^z=s z)wWcKB?oR@s`H^jc(fTdLf>)8jeE@duT|3%y+SiZ z5;9VA%xf05CY-xs_wS~<`o%%n`Vb;NL2cQ752fk}ZfA2KD;GGXt26p5>{U6+qI!dY zs2YKF;homXA>WO_p{k*J(eT0Krn%D;%6HQk(0^dkgNN5{4(eAMx{RR~z$aCFzIH&F zv(!U(?Ds!)RMw-n=JOnXuDAl068?o$h;Tq@&2UblkFhZq$`ThGIL9^snvYpGToobt z6eHwQ9+}VPE8f|{Jip+3GE6s#_CV4;gZV_a`y5p#fo~uKy^eR0y_M$t4%GQ|44snR zKZbpUs1gU|z45BIxZK~6P354-kzQ5stlLKU0+;Di+zL`=tE@IMI$9@4J2LtWzX+g; zmZt3NZ^1t_`YdCY>!_?7g(#oFLT*lck>mU*Q-{5%lZ;$)_9DwKe;}(DoyM@;`h`rr z6%BkAv*of!ReJRhXsF9wC!~w-1?TMo7Cv@`JQ>i&^A;$t8QG!l)yb0<9De zeJ}_5wjH@sHz0bt%ffGtufaucWjYs}q5KnegCqLf!FGsl#_*Tv%uHW`1ChSknq4SI zNc7BG(;iUt@8UL z!eFhopWKFsgqk@W$B2x+M&p;=boj$Z)oi=u_I-9ezRt<$F$;p5S{-6HK>ujj(%T?# zB35En?es}^)COg{;eIr5=X@Lvjzk|`2J(y)~fzGexf7Xv-G^}U1qOpU%~Sc@p*iLI$j`oP^!NX z*#Ql<8&)1at{3GS3BRtg6r|l~fXgiVM^e=>8+8UvaH&blfp&CemK{^%8Ng;JVI914 zZu_?~S5)bjhcen-u|pFEpXA_kA%CjrxN{cp$saB79Rg1B(QAAo+Wb1@6nMr(4!Nsb zoEtn(r=EUvHFZk)?(@3(uzd-1VJUXeUwRvsBF<;gT7cX{F(-IGHDD3nIB?)IC~X*(R84KRwfAtVG>vLFbqXBT6%quhOUcI(f84KiVjUn zIOi$H7aGahr+F7zzn;I@QK=_KC>skd39`|)XA>S3GV%+hz%A-$lcEBy_P zehXNl{48MTfcPgJS(Rl+&>Vh-E1l&<{%`i)1S;utfBe6Ow8cQovGD1WUrmS&Vlp5PykajZ#G8a-=S|(``$PIFXii8w}5E0q`k8`Kr zZJVxh=X~$E|L?c+oTG;W$2UHoXMI1P&+8@X0S8h3jXT?P`z1MOhI1*QSAW@sm&0$j zha((&^)$346cO$T9i1$HUctEx&S_0idgYhn)OR0>dAQOIq^*MOAUEOwc|>+<$(jg3 zw=HxPQNTeVzF6vqAbC|$yNbj$#)i!ZF2%?H+FYjFLIPH-3|8aT=c7}wchqe)>~wQSc)&uT!#J=ybOOtIZ;1blxfl+A5(J$$ubK^o z&(&DqP+Mm^Nhw-X#c9#y-7|`kBIh@Oqnn?U&=bxKbtJFq_F3y79P5ehlIlrzWGgrW z5+=!qK2o-!!ebcnbix%&DGR={D1QxncQ09VGp>57MAwFCG2k0_AQJORjQOr+y1<2} z^;GD#aRX(^g!l*qC9q9h`?FS>!c>>5Oc}0@(WY8Au=_kAB!@_f=-|SG(Irhjw8Y{8 zswiO21Uf@~zRdA#uT6#z*c2m7PxEL@-43Z+nO@UiR7=wfR9Q9fm0n1W)kT<+XXl?H z@~ZPv1hKgk-}L@y-o?ZHQj!l>75A*44pR8lR$5#xxVFsbbmB(hLIDCiG*-i>XsUl> zdf11VsTVJI#$}itQ&^Iz#Eeb5`@wBEp1b>R7a+yq1Go=96x;_F1?lD~WU97he{i7fbA z>a8u?#@J5#ENjVS`RN!`*whzmM;sjXP3rL((>{N&W^(fDve>+by19W`23;06y3Ab= zUBumxQ?Y2%Lq`50p`-SdXYW;j3p!dw)vatKhE9 zSr(U3W*h6$7)|AF+!^l_vvsiFeXion-@X`+-@{ zmhBKLY|c5qD6QE()F758=7y z{70*(>slg(X}b$~m0P?hD(*^iOM%W%){>|!D(L-v7{$B1zRq7r{vrT7DINW!<@Ax2No6`-KroxA;dwtqRL+pR+ zY+L3n`1y;msWm^II`Dz=Q%J`gdd8-&KwDn*)s2StG)I8?GKb?lzqyKM#NLlxYqsFxV|a7 zb;n`WzN;gS9JsJ#-G-Cnw=Y>6{<>_@HkF1OFZsRMXK3GHWf{ZWwhgq{*8|DlXAS>A z`Le8z>3Mpf9S=Ix&jEiSRFLOzFpORNZ5Ug+YyTn7pqFdE8b5qR>V>N_WSrEo+n5TA~yE%97gTAKQPL??utW$Mt-17+I1O=E=sg{^MZ{+ z7d<{dWyZ)OpRHK8ZvDyOOHi-N{+3&I>ekL`tB6`LFe)7y7?r+WKdQAVDt+{XCF|BMoN?sHFBfKyxHjr_>4N2y zzaI*%xL>vRx5;M^UHKt3_sCoQtCN~L=~FOp#r{M!`o4fWlXY7?Q9G@C-?{GSz%%IU zCkHhE8P-hk4E}EH!DCA=9G^CARKf7CvzDW;H~irs?&ldi^37R&(M|6Arka;7% z`0TT(srM((zyC$>%ny{ES5GP0)+Juw@J2J6-Ma2muz|(VpQ^@)DatvgG2LJ7p!>XY z;pu_&VQF6sEI3~;IksH>P&pq|`DogNfi>3nfi>3VRde=`SMU1B-0fH8{ejEgy>8H# z9sBNO$9|-Z{cjF7q`PlKY0K2d@x;Yd-v4}Y3%pSFjbOA)eHBmqH(w-fQD*cY-tAzP zFHe7DY<++1P~7(n9`ryy`t&;k`RGrf1fz)v!Sn3a7E)kP!=|Pk5&Y~mCDd6f-f#x@sVz}plZy-&!jxu3D&T z($CG9F=_mY6|2{MJ*;u~>yk+JYbl+TfBlVoDt2R&C;COW`}Bdt>A%e7h#a8jS^DP!J9jVaoSSEe2L(Wid}?ori6IHxJwXu{`Xj zVDFw}{CA1S#U?%ML!FtlxK z+aD$?W9k>Zzpw%cL@VDxB@ipoKJVoI_W1m9FpwFY^&d@u{QG&v-m#l!%qii8)W#F< zym9AG*T(J2D|3~7GX|Bg(Pk}AeEXPZ!C^(;)sIX+*bhuUEf)tp{q$XZXZraR4BU$L z+szY<|G8=`+Ck?WNyL8O7aCiX1m640zq)RT9NNWi_v)J$&33b0|L{Jh`q8J~ZMdx< z;WxN5a4hd?Lf&4=HZ)X#;rd+0r+~*YERnN;!JEXq;%xiXD+GX|iqGKG3z*9Lr(J{qq zR6G;8<%cR53{VQCN+67LaQ1}Bu8_?yINlOlABew$iD{fD>e?BQawpJH>)tZ0zm#ub z1Q7J~yu6K(`rlxbExriU7qq134Z9vlVdYYLbhsi$Y zJYD3uM-vFQ%ryAIWUE_T;*)z5#63P<{Suh;8K>IMQ8%C1+{4Fp%5Y{`T)LB&sUrZZ zmu4aMrj=Ol#W5OdGevz*pJosleOuHqJxT34o!*&G5M=~}ab&AK$8|r_Z4&kC?rbKW z=VK$~JNhy=vDL6Zt&7J0ItffL& z*4YOOkn5Np<+9DPfD}YHfR%4d18i}FNGa>o_B~p!=G4WsAv%+3{&M3?Z;_}-zZ%p|%BQktLU*ys)&$-Aw51c6Y3>Sfm|_b08yry$b+QCQ;6& zLs+&pLg<0_m1nt?3l1aYZ568MYfO!h^8mDnrz_Tl=?_ z2@6{aOX!Mj3Ym#hBx$Psd}Zq~g&MtxaeYH>2gxZgIh0e|A_{}69A!MMD4{z&Ai{wu z+1An39>}>|O@lfnqk60JGmp^0*E(f6JxQ6_17H>H-pWgoa{!1g3@}IR=`@Oc4e82z zPMS51XY#*Qc%mSM)EDZjrUwRFVL(I-6AizqG6cXNE!Boaa&r$efm|ToR3i?*lEBU4H<*#tmS4-jKD6#z1eb(ZHGIl7XOTN8_W(RZa8&9Xq%oeib{K*y>< zEU^BTcgEo7#dbwF$q%F+Hsoga<9Fe)6EuRQx;AT)R%-N^ zKQ}rI<_fsI<(*5ESYe>d60uv(2yB=O=dUqb>ZBH^b%p{%Fk=(B5x}fNEtnRKz>cX8 z(e#$LJPJi&CF!~FXG$g}rUw@rzVjuiQuzY2GOv>wm@amv;A43}-?gR`(Z;XB$EUDF zm~KjHwj@_oHJL07hwtuAEjRczjuYYM3uodY1#yi0`D*=1i~q|W{r(QwPk91uL^PA5 zg`e#=Z%ElEbgD*4D{GQyop}KQ{r2aqXvTTDRA14Ur^(yWlbjl=zVpydglo$IkCRN2 zw5Lm$2~V(=Hk6gj!h)KyoR(bc{CFdyK>O9{xxf^l7v1k5UO;v->wc~6J~Phag*gy+ zA+NU@aO|^n8K^ZlI0nG^-Od3Zwd=krSz1X-i9@A7m3%!vBZ83YAuhaYhsKic*2PpC zs{0tpSfvn1(^v|lY&RVp7I4jUS&C4)1y^E;6fJvgG9@ut851sSiASWk3IjqkedS_< zms4Ya?>$R}macF?v4dbxQLnyfy(Fe1!Xr?6TAv>wyX(v{OXvu#4}_KBikxHF`%1B#MOIV~&!0?Q+nznfz@lUt%%TKq&QYvNhY2 ztaRCqAX;hGDF_ey%}{E zdq}Z?zRt*H&ICl0LMJnd>UOFkm`u$s1RFf-C&D%7*!1HAE3um3ZVa1T$-ew(7vJQV z#|L!iM>@c^EO9)F77%;9+hP{rG3rI~OBZdG)?e_%YGklBYnQkZqIw`J>l|JwDth#D z4yL+4Jo-E5Y)sm|0F~gTG){Nm- zNR)zTxW`pD+d5Z@L;YTkt5V@JwFsQJRDu+1*LeysOw)9R%3IiqnU4k!Q73mYy2%BJ z)<2_Z^q0m6%d1ZJ$yk7KZm8{mM2F8qdDEkSlfiurspbsc+A9G@G&G=$rbB&1-|2+i zmSBEWeaarQdakWyUT>+CD5!jK3*(3^gy-)w!7XPW-{xF4r8c*8Tv6X+JuxRN)ts6j z%daM^&o5~UvYf5S-zT0)5@?;;ABkQ6`>E~X;tJR=lI0Fjdd{!9EB?=es*EXxgwno%So7IRJX%y|eir7OY>Mhg z`l0L*r<)uBCv`*8J@R`F;NU2j3e-`OaOY9sCeR1tR3l5`&7!chHTHAhu7(1&=`?h7cK266JF8N* zNggCSHG@#&y6wk6B`8S>#p8kyeh``=3$yHqu;y{APP0VXA^wDT61@e^)V21;egoi+SOU+`6%(I@W?W0mI5&6d#S<@d0XmXIjNGVIR%A;>PLTjbE7ps9Ew536N}WB zdH_mXnGCS*O08(BybWLw2qAKh^8Dx2&FD3`d~pCtm`u{Ltg5w0PVDz*gk*}DRc@|y zhh1-LR=m*iG^Lx!VEJ|Sso-XgmfX*xvlfUmF_I8jWiCCEp|9Wm15}qK%FxqWn5?ccDAIfNH~- zHNX!KatNxbk?A>M@Uzd0WS2})*BlB>1%0O#XDT$!w|~_Fy1JOoOS^2kNGDur-Y)7q z1K^1o)4e`xT1J8T%09m~;d3O15O01e`Fj&nU8~PSh3FVi$O2hnK1-Q?G*CwGY;6XA z*%;Lci*OJbRG3y4iX|imG{dEWalSGlkkaVxR??b?)rM7CAo3B)exkNvs*}@OVnX-% zQEW)s4uy}zt9GkVQReM@-Pb^#W(uE^T&NyU>`o$SEOZKug%ovXZ%RB{kz4^AVgjayEIL{&6lt|YA*8tRN z8{M2Yvl~lbGuE27hCxy6qZ=d3%y~Lm8SA+^QJZy>jDsgY)Fya1VR7GzLYjx^u04@w zOxUyMUb~gm86b7K``bfRuq0!xchGe~e<+xIdgO@AplX5@!{`~hP9@`1*n+g#p?OR*VI&&!)0 zLGU*X2ix+m8%p7b)|4Yv0Xwxbm9RJ^Ix|iATwKe!Yx3!W|77B9wIs9>jv0tME%TLd z#hX<1cTnpsbE)B~t3F;m*ZYq>N6vr|@5zF3{`X{IIFVm&Nq1!6q_oTX>qcCje{$vQ z^bM0L=B*W3wWs|4Lw420db9|0ef6U=4!i4m`qYa9l}D@&7NXZX{#>YC@0gUN!S8Cd zbUwp5J!q6**lxQzvU`d;f4Rx##AoAvZQQJ^nUa{=_qVX{g*S4ntlb#N8^YR3ehF$V zI|;8fR`@2scCKJIc838(Rt)=uYOk$12V&pa*VWr%ioJ&Rgo(BzTQ`zIc{0*9zF1XN zt3emV?G%Pg&!om-GcBFYa`q?^q0WaT4nKCWR&+Z$ckZkpYXW``HJkmQY7u8v2C?e# z-aaEb{zp{N7Hoepvzu+T4y%R3lv6W^L^r9mSGl#$d`WU1@Ylt3KHGt;Q6-?(!o_`nSLQ-u z$Hf%J6e2yH%S|^@%-wF`$hDDl5~M{Y&XD&px>M+;@)X`;VVnl{qS&Wc zk+o)M%OmN0-Srruwgo0z)t5@|QzhJivtBs!%}OqtBZpL}EvF0|g}a4JXb_rWHN+}> z^#EMGr$0%yN5L=CCO0<0X{jbd?Z7w$T8-bxUexDdy zr_;jXWf`3Acz)I0zGM#zmDAlO>93@iv5t}KMl4aH7R4EG92tTw1}Y8*dUspL6P8J( zQzq2Vg-lrjaP-vBO%*9DPe+I{!DteQ%8@p^v?5Ml_e-M|#^Pfg)Si$QtrwmZ$Pp%B zLsPUD)M&o1dEW0svXxJfEC26q}i9>QVNj$B;}eC@O>EjqL`Hb~><2l3rxy zy=usJ2>SZFS>rd6(x=mtgtcT#Y(`Gr&8}BN@IT^4AmR43N9FE)meZ25NRu`OZXagQ zY;uIawaxX3=TkC`Lki?vO%40bPhQJ*uRN7^r^dB9kbnhJ@0(dxctXjnpbg~Zy} zUTr>gCZ1|J1eyqNC$oEhmGmhX?&fAKf<^H2g5gEdezpQbHKii+5))H2#X@|)++xmW z_sj`Mwt@%=Dk{86w~VZdXt{{Wd&1V!A)1@khsD#n$B3J8xs}Qd*eXdM?uO1o?xtZ- zI08e6$G3*!jpAS3k~qj~1ZG%Qw=SnZA#z6-6QzvYSD6)(DBbM_upky^_N8T35~2PW zNzUb#Tv?!xFHsFU%AwD+EY#QT7Ta32s($FigGZ$`kP}ZkS6T+upw#S=y4$wYhc;ae3mqeT-UrC3|4P$RkXv-ni7+vcLt*QrC1Bwzh zGaxYnu>u8HNZWdeEyORvZ7RW|(h%8At>7DxF$&;8(Xp)Va7#_Mr2_wqC#IMel&};I zHtGuhtE@abda`6wp`|o~fDpwyLgdCQlzu&?^H*b|ZDdjMtsD+hv)`S?(?`#=ysDmx z$jj?;nwkeTGA$ru(WL>f!!3Gd$=tZ^GXUl6&Sz*&3JFpw;q*1@O4$T?cUVlNqzVaW z*(;)0*QIQ1tEVJWs|%qaxTzu;N$wM!w=)c$1Rh@(p=HEskFD{rSc-KkrnojBTVBpH zR&FpWP55F1T7aggC;;Hw?n@-nfuXCY3N~L_(hlch1}Mmy<*~S&iilm^`2zj@96;#} zRrc3t$Rdx9OX?*Eb~#Vnq%NvOgqV6RnPLje6>BwZt;y%n__MnF1YER%3^nhg25|MP zV*K@LRDo)~CUOe<=v!<(YX@}}L%sVshN5c>gO=*=E|urs>-^hARyj}3v!+O1HZ)~J+T?Xv zVy$4D!i=IWOI8!<8S~@|dwdhBx%0v=HJWK+Pi_heC0y!0z2W3TjL6DnH>C>r5~Vmre{E$nDx zO1f%Cfu7=ONs{>?QrhI;k^fs+2$`Ubt06&obU_ZUlI|*Y?sjg&)Mr^|tB<kO{NGcaRs}Ar&aIU%8R*RKu?sa|@ zg|jIX=bAkxXf2oRLjjUMfNKx_sm2g3im&yD=Z2Cuch_)fLH4^GASKj@q?Bd`u)5Xj zj3SSRo&jx`JD#v~d~$Jh43*tieN>w}k>I){wGlXyIsbwsQpg6_sD) zCTxLI5(*kE$?6P^JyY_;Zqpe@vVsA3G0$+wrOXNy1#k!WF|jZ|Zq8xt zh-k-o0$X4`0$*N8ku1WR7PW7p@T=A`Ydtb3sG|V5Z4g$n8VO7kSgty|niaD6V37#3{OlL;7B3>9~Pj!cHy$+N}g;-x-uG&TX=d(MMPo`kTB>9OW>gc)Y#={=94C{ zo7uvZRpXxakqcDM+!m?LBBO+t>2E^Hp-Qipj#iH#Bup7JZ;^0y5J}Li1dQ}N2uXDT zCBhgup-#@>oU_J*)f@*4NrO_Vd#ke)c*QZXZzC2d$%n$KBsprm)L7?+2$6^`0epr? z=Z40$ns)aiVH3y1?V2Yk>2<-I`H|usG^6=RGNpL!f2V?97L1 zDK5f|HRo$uuDQMi;>$HuXw}kKI>a5&*$7UihAhB#d61KDV+ZA zl*=Jxo9>+D{7?_Tz+SFsJl0f0I^)TqV_8^3?dCK9em0yB%-<}ulVv45$+i}F+%@1x z@|O>EPeRVPOU||^oqPIcx7$!Otzni|`lGhQNfH2DdFlXcU?m&u_mRaNLXcs|Kp;r2 zP)jfGk*FW4H7gj;bNK?s4o7HAL>$SPVyg9ucd`c@b12$D5PGJp+7;ml>%e!_kfZY! zRp*z9N}ivFLXuGBfZXo30L@@%HWfx7yymmDf{UX5=wnexFNM8zp?@NgSWjT+q?bDB zBH04na2~{$)A&HOFHdZ@DOBh@K&pW|dBKi$>;$kVxt-9KB6%7?PBvYxCx@sb(Tuoo zXF#kKm|9i!N7y!4wvVLtT2!d1ls-C<=1kGkpc%7Il8Y+w#mU>_y_8|(N;MJb6|g%u zSIsBMNT~G)d_09L6(FvNvUE}L_QiTm7l)_Ou9rh-Q~_p7=kIv3tO?>)b$%_vj}Y%b z%)CaPB>a++aErudm>RPo49(9QA^ZA>I(r@}62V?b8)pab`d}>fWoS?!(ar%-%`7L1 zF1q0|Q+*YchgF}4(&m005G@d1;fXw|Tr2?A47R_07wMw-^nem|5W*YLxNfB-R2xTm z6e4-LUV}owIu&FdrryAyXaIq{WM39zzI6_NYnjl~+C!EO%_y&SLgX%x96uFlC+leK zhoVI5b)23vpxtEKFf`0|rLUHawf{PVkfpu>Wdq_IJ>x9Sd{~_=Je6*ilb}fXJ%O>c zFyEbLXO=ly$6Ll?5cPU78JH~*mJm#-#*4T-3eoI}HIi}&$-w6qr8Mq{h*_jh&x$G1G@UdLU{4>yK`styT2!kH z@|wq~ue7vQ7SxKXT3qyxdTeF^e0;IMDC&gU%wkmtvs@&hh44AuaHP8H&^7UC78`&` zcmaWWI{?4c^sc^_BkC75vorCv{dwF@WfSTYlKE7l&7|_bCWvGD1JJNtH5Vz8lB9^p zB;&V|egNaYXQkCAMSCeIPL;ApcXSU!14tWEwxpkNC)mmF1zC!#>1VKVN2HktaP~TZ zCya})pJ*K;lZYh08iKWqIC}`%LYE>6=c@Jm&jAH4sWRBUt463Wzv3wmCo)tmInG?S zZSBR?a=?NgP};;$lr$L&@v54eNkzArDjoxFZ4HG}r2R~x+U&-{NFG0zJlPBuxp#q6 zK}x}B#u6;iT>b;V7yUA!I1%F3$HPGn1eJr*j-8q7(P&%&#LK4{n zImldNBr9WEySPdw=YehkASz8@x9Sq3;gu+N$!0b7s6GEo8-wCgyKp*y;^rrOf2WcDEmu!LqV5G zFZ69hNOA02N^}S?+3SiQ8|YHEZXAHco1b0+R2-UrhBfe1I09PQiF!WwrmNbtSc^*( zSb3(js9yFuBVZjAnhf+#7U0TKB*^p9R9l}bBAJ^S37iN(P+~;MwADA=3-U{Vio|-M zmh1v6(*x0kbDyD9B$gG)Tse1h*vHIq)Qd$)<$Fv5dv=kotsq|r5^Z`BelLeK?iwwW zlaF>laKX2FximchX=JaGxU^V~>6;w@JUZt#H)%_QbDOCa;{~{Znt1T@cAXh5$xCoq3A_7xGVO<*HYC@u*31Bh3*tx1Ws<^Kj z7?K<0o0ukHGg~B6h65+h0vRJqZsQcr23Nz@3BW$-tUZ09YDV}DT(k^WBleojQPQtu zdVY?!6_w=*Ig_U)btlQvCY%9uJa0&-&}XH0T{ioQG%yx+R<2}fLJ^KPj9{lSU!8}> zUFq2vld?c)-ClWE?3W{UaU0M8%$-1I^6SCz6<$t)w5iX#u>ABVkoXFIj?SD|V0=Ll zpXMDEfqWiElqBl3;;IPelPP78Ge^#dv{n%T2y8!hGlD4HZjQw3$a3Q;a%&xIUtiifyD%(pNyNj_h_qed*!3I+OxUMHGm&IZU$d0CdOxyWjg{97${T#PZ~JC>#o9g7RC z#E0x+0WLYxyY8kL$@fHfv(~0O%?NNIQt+i4fB*%d(24u=cr6(Q)9xrsa?5~~L)|0? z;v%r`Nis1pd3kG7nDw{ixd6w?xqH>piuzG)LdCLnX~?5a(OOZ3^t@b95jv`-0_=&F za-fL3I0x|6xW}L(M#nJ;#k}vlyrM$B9qq8AF)a}DC={BkzKAqo&v!!6dDrzZ&-D6B zJppJ|cQ3y}(ij#KtYZM=IH%Cvj5XcS;bRJnE`}WxpMaMpe*lU%P*BXqiO@4VPo_Dl z?;@1yZn{{;+Cj0K6Hd`pLj4zUTxH2|#h9lxa8Z&=2l_NTNz!*m6NqG%y-NO-!8715 zm*A0FwB#m~bMMgetpJb-wE!S0FS%wwJalshhBJ{|kw680jP!9LTszMtP)9|IYBc$m zjhrg8iWi_wzH3Jh5z8m)o%`^_%Vtv&8muk|7*0teV4k;jAE!Y$BR#6>_g zLP>2^+7+QTMtS8GioN+HH602hR)>Uux@jF^$cIK~L}Fk_P-oNGQkYLH1E_M^)c69) z8i0(JH6;`lQ&rLxa{LvGa~L^`&wh*@I*U~%VwcU0Jy#>bOv$LCItTa^PS-C0nGOFO|h`Vy)JpPjpkdip}Jqal_b7Ak7ff- zD>S!Slf|I{;ph6L;lxl)eVqwGQl=x?BwZA1I{>WXJ8uN6L;iZyoo!)Rn<4wy@CDCv z+HIn7d&^_{TJGT^>vebzDUt->pIT8;(s@ZrA=?>67WH>hZHkiWEBqH2Vxxie1Boyq z@Pt-d1Yqa|N9K4iHHM{<`jp;2{!$&sguiu@=B^Ow9*0=J!ZCr#<(V-`-?UU7I4c69 z&Z>wY*@{DGo&{PUQz^?+^2V(+Nhy#uaOPrFTtRZw-Y}B6A;+?Yl-?cDrRRo07E%L1 zssfD<)!msyzAWcnHn1y51H@keQQ=X0UrsS~XXK2!N0X{xTP?-UbuVtZ>eJD!t*Td3 zWMqY|y$E~y$T$&3ks&6jdM+97hC^IgJ_D|u1OUxmB!G)BR^qhr} z*^+%R4$m@_Jm4fj&u)ZAz{4wf3nV|t0Op^1a zj|7|MqYj~JAT4`Vg9huXRt?dBAH{Tv=c1h^fdBnRx;YM40J&CxtNm-xxk|5t{0_a!OI??!ZaB`je*>My&LrAZdi9GJuA@ch+ zS7;Wp2n*#SWf}@9wF(9ZeiaFivms6~1zNs1NkZHlkR&8Q+&_(Gi+q_+XB27*gCB(P4B>+}=rp#STEXll}S;N}211!oDq7+(RHc=y37EPGz3L}|;pofCF3?*;YY@k6F z@ttBwFDOHu)S*$pa@YBz$YUGTlCAXhkPoF3oWmeDC3kB2%QvLV%i;im6@VUVjy9?G zL>m`K?tjjN#A%$g#zoQ!S4)T*9E+-|=>WT$5~(!UM&WC?;EoGUE*xx!w@PX~38AJY zyEKNHtubY8BE;G+G<6)5gvK&rGl+qvm%R|+uE+>L!`&r`O57fx9T(9B)15ZZv(@KH z;2~uBCE1}(e`QsNLK zCon`P(kgsnnETf2c%gi78ZA(P3&aHQOL2_gs4q7LXbT7aCy>kVzs3@^r3u|_W{4Ka z8mp5!Q)n?P=dRuyfo^AKN`_M3dmY;TwoYB!I- z(^^G`?>a^(VO6^UYt!S$Y~UAY=&vx3pXL(#d1~)Kd({&I;bq&B{HWn*HrJ3 zM^W`(GRl@V+B!K9a@02)*-WKo?pj!n)Cz6?vIYn&q5vP;flboYKa66kA0L@T0XD6G zXs?|$k)WNUS)jg~u&gGyKfF`Jzo$oRwak~a4}S=;`3|xf<%7n>;RtPVf{llzRGOv$ zP=ER)VL`Olyw0JsfG;bjLd|xyR7jS^q%ilHcY?t`o#<&8+oYYZ6%!F8NRS01TL$2? zB#Uo*zM!AozzE-!GO*CpMaP@7nEoi9QiQ3^CNojYjsTEUi}lJIkTiPGSqc_HqR)4A zOqNhx3GJ1?8{*2Ua~^1Aq=eRE;&e3%;qeHIej zxRgs#m6WxOIt7j(DqJl4w3ZreO^`{N;v82kANSD0RK+QbP)VLf^!z6~Vw9+VVPhW9 z{+PD!YTIJ(B$Ka~k3pEaa`}Oh`Y@uKEX{Uc`;}dN(Ul7Pg1d0D+57lpyJMJ_;c%@Z zQ^%|F@6hn8`xjyI+TrPZ;5g<*j^fZo=57FnHOkVRLG#r>Y$1;#fh;xNQRzs_(#0$= zd#a1uokYp^u7Sz#<=6+aeA^+hj2iug`Cv>#WSRvPR2R@F!mEIALQtisY@SFCBD?~C zezTkQYv6to(UA+Wp4oP_QP|nlIC_*RB2|08s1S>h_>Zrg8 zf+00j$uYNRJq3IP^L2%ifiKpO+0XsGG3z7HKl~KG-M4Eg*XWEleaz`Y1ERl6w~1qM2Wmh;Xyq3;?Ni z_Lb-DD|)~_JzT~p7A#XF7ol)Pn7iGseZWB{t**-S2r-GhAe4S-?BON;=)21;p7M!WFGLrx zV{}o_2hl93CLba8kkMGltmJY^8OSl?C^(NRNC z46x{TvrF)5ftF%QsuhEAi3ud9kz6t1Sn_fJcVAS^$9Ds4Jlb2YrmVP1blR$2Wri_Dn304GAlCTI|THR(ZLu30vq1(n*BE}wz0tjQp1wUDV`<&@zHiw@IP=h%HKO><$niuvx& zGUwfaymCxiHb33?JUx_I$B zt9N8<8*BoH(OM)vW}H_AIR<>HTHnTNi|IZJjLi z79~BSC@VR)uSI@q8V8r4jR`Rp>mBFl+;JRBZvc#$SSV$DgW z!V2~zaQNi-s=6YAomU0x){vXjrNykia(4Y)dCuj|R8i9IW5h;hk$y`eE_6n~W|JgE z@t|_+b6p6KM>|F1b1KcB$#8qC4+X*1f~`zdy|;3X1(l)PKoXE3Abrd+EH(JhB0VGw zT^LWLmM)=LlC@x$T85OIqtDI5hIv?$gzzgC(Y*QaB4c+AaO&Achf6_j1UN)6H%Nz7 z2|~X>N!uiFP-qh?>J>aFkw4_=xiw%}A!tp0ajEl0gry^c4mz46TBgshVC7!5t^{{O zW0(mPEmn(4*TwYc0fF8L9G{zHy$0YZVbV5|lRzhOMC*w_5h{7mYTQ$&i>V6;VIzv_ zYm)CiOapm?V2KMfKA9s72dxk~)p^amb-=&Dx-3rx`Ay2W9CdAt>IAs`xx~0PHgbvq zc3Q8MU`=$e^>gJrp^}AkCoeJA*z%Gr(kw@|&HqYVlzeBv;q&a^^Iy=$B2|Ly^C%-$ zEm?1|ATw1r=KEu1Oe}+>++3qf*G>RxhHOMXew^-(r=^`?cTBhCo(!B$Oaj~5d)*u! zDxD6yZWM(JQPowV{ur=BHDp#NKkNnitB&-RXs-o%ViKLH+?3uIEpvZF2$2wCy(J)} z3hoW}LQ%CcsYc+@=nY9vLWqQ(2s;3UmuwY4fYB)gf&p$|9+3A9oXrq!!sZ!hU~i*t zSfB976A~idznbtYX<$<b`tr4G3r+rG;Us}TETeMAmdKu zO5!ywt(6TwBcxv0KO;n#27B?>83bRD!pH65a|W($te`(wvnt9YRnU3H))0ifeOQ9- z_U(41N60mi^rf;^<_YV0nRM?baqn#Q-Jc-2zuyd~$EnjGu)c4INl%~gmdCw=)mA@D zgG4MFEH%3A`8s0Ki{BsxzjIqRRK{b1IIc@S!VX{Y*GT16UD<>$AsJ3FSO23pZ_mGo zg(tow?ZK-ea^1e-({DE@5 z4t;nw^z>%RrT;APzT!VxMbusYDdN4?l^pVJY7^16>1`Tc=xzdg_N~DYK}37yNpE3O zUj=zueT-L_s8TO{CmzZ3>p>FG0P)Q9+1$5qxy4IA0wB2;(EO%K;Wr9p@Q;H8KvzYr zeiHyayY=Iti2Z*hR9WDF0^y(Jh^Rv!flVKUm><0JP;zVW-v)`fMRRtc-{jn0-@_UC zF&=)-@Hf>50}nv|saQS--eBtft5|kl{FPY0{Fy48GvO~?F2u4wak=6q{-s#LKNE}c zmOSLow)ism@Y1LOE#$;X=BBl;mr=(s=eJwSyg zYOq}6sx|B1#+PPY`Y1fC<>EV>G5`;2a~w20jPCO`_z6Y#`3OAhe{rz)$m+ji*8dV& z{U2!dsNWD!C!f@koqVJnu@o}2OA_eX9_zB>1Hxo+6q`~iGa z1t2`n92~PqG2JhEQ-@Drf$wIApc=Me~`KA{)? zGJ0{q!!`J7bQdOG3U~jHjWh3u0`t(rK~LvZd*3lMRPFu9+Tl~M_v9Nuy#Xe@|E1OF ze1afBXA!2j0awU7OX>mAq; zp&0&cPW%8_{U4b1U;heO{dY9`Z+1Q9!*}@Emhh~P*!A8svi=FbC)4wjCiU8=E|{#D z_r6Eze@^1?N!j!VUWHFGD&QLW|C7^edXIA995vr-`}+{`wubh>9=yOZ@4qeiT=8w~ ze*+xZ=1B^#jCtWdngDrs4>b4$ne&N5bqnN06T16mym{vjaK!_yPdssO_9&qBdHa|L zXno>|VEXB|G-1cxoW!O+gMT^Y^X*60ezRS%aH{<0F-vQITrhpgrJAhOtAF~!@29I* z51t%5ebUBknW`qg;?nx_7c5zQuv{cI*~~YzYLRT^U76Yt-i@Ln!wq5bkXRbCPb8i* zyKel~J4YSecW_1J(kTb_Fh|_cOc^0OIyuaF;Kc#yU1s^M-NeX;lZI^f+kfNq;?1Gw zil(j=Oqd}z1yxIDxV1<&{e8*WbKlH(JbwI+&qtOHAMSBrNcfWdTl_vh;5vPT;N;}s zzylwAu|cBE?%}T6QO-e({qmc`r;jfWU3FpVwAu;37$a^+)~rh^=P0KfxV~yx@THlv z>%RWFW5m&Yhn5d}mi*O0`HC@An>;$>^k&7ARg?D!p{M(!Inyz;=1+u37>#eP4gXy%gZSB8D? zMM1UFwLRzJU4e!-xNiDjcZXbaCuMsLy#&0jn1toEEZlY}_}8GmbCcw5kU? zoG{<#8F=I9h&xlh+kS~|)zjAJ|@7i;7W<36C{L7Ie|3wuJRPH3U@FXH* zDX4(V9V1qk9-P*^bgaWShpES3Xh)iV$hZUEu=(oXib;2-_-#E=etnfs@TFPP-e`rt zH_08a*4R-seUHbT?LO}`uVq=lmh!Z`Tf42j!PQR&)!REP8vF8d9{4~m_<$Suz#i~{ zr{DwN%O@Wg_(06R`GMI_b1sfaZHFHI>G*QrRTt(=tNrSimm^o>X-}P{GitWz!k3Tv zdgq9v3lFVmzB9#P>j~=dpMUQ`|LjiZbbDxX=B2iux$)ED&4K5Nrmq!zJwra?Bx?A> zWcI0I_mR9Ux{Zs+jNdV0@LkcaGCwO{}8a>VL=ho-SNy|O`$&%51I_4DM}b>Lf$JX(5ag~y#K;op4qdk^|&cUq!; z77@DTvq#R`zubT0%Hqww=Zfa66?`>AKJugnKPw73KKFJ{;g6GNJOoK`#bmmQ;4?>jiHa_QLf9^(#n zt{HR9Wyw|Eun)c{`DrmJZE}?9_v=}D@b&e)zUthSx+gn^Z|k%yUfFN8Ae}I|-e|R; z8~oB)EePM5b-zt=L(X2MstPdIw4n;gDQR58?{ zuSL<4__s3b=rrplH+Orl``)2rN!|yw75#HtOrsg>>3w_=lVHWZj>s9epgy&{DmNP9 zfxmUyY2uOLC0dAxV|n;@&wW1)lLwej**HVPqiSaTObIU;{Q#|m@97`&-4hRYcQ+Nj zZLNSXG}yB9hB>iCHk$y;b|eMrM^?DY2>a`)REwQgnO7Q?soy>P6Z_+6>o`DPJp z=&6zbhY|PPt&aW73<)?%`V;>(^wW?c7F0ZY)c)qLQ;PA!YjTUqt zc{#i}C2)d+pVhgfq%vk}?E$5)TGbF~_j1%m$NjvA<8VK|C`t8LTR!~dgcCEZO+7!Z zgKUgigtJ;WZ+VKNU+#~}K!>rqqO01G8k3*&S z(bEy~AAw{tU%YDG4yX`Y{ouAnGgQ??&I(W62#l!mkt+tS0m|BsALU*}0j=!n%w5&2 z-?jhwtQUK#fe{uown5YZUymGTk~Oz=K2Qzo-5g}r0%h0Bmz}|lzJe!!W}*x2$Y!kW*tyQ9@Sv|!`H8w_*#N}J#<~#x*Ognid^x1 zksRHpeEsD)TCg7|ixf@$&uHV%%fd(a`T5d+)G;Un~DM$GhG^I&s_0FFG^~}qno+@{s#B4=dMDSs#Ft+IYtTvftx2F&K ze>($(qji=)&80&Hb-B}Uy+o+$>ukGyybvFYDL0DlYMTJ#$L!GMjh#T>F)i)D>tjIM zB=$ll(Fo}CWdlP!TcPUh8_R^L9zfAZPAix>0!XCdIKw4Nfof}Oa7Sha%RfYD$c!3> z^;NRMbXLPf6NnzDcl5hUDP;HC&u_eEdRVohNPb84pjEn zS=Vc%FXfzv?4jc8h@pP>ETLk;-sx*@X0z<<=gZwRRj6d&RZ1V*ElstP^M0Uuk!~2R zr)L`jX=s(d^57#t8IV0AS9u9k_RKD_J}3#4QLU3#zGgj_(zoS)PFJ9c>Oi8}UIRLn zc4f3<2QZ54AI}#x#eS=LSP9L}NDP<*1Al%9cE#s0BlXDf2Gg!4wNO5;eyqHdI7BZT z(z#*oh=tYPUR`3^wPC%S%hVoAyd#Ip#nyv$N+}btzUWbJL_f4@@a>f6kC5FUJ(kfn zNri`#@aIqbE^_LN>>tN!7dOadDilMr zGxZ<(H*{U>Zzjq~h3`8HWcR$*-Ak8ht1*uRySt(5BhW{mwGx*tBjAOA+bamDuov4+(iKG}OQ zGZ+|~v$btC=-7U0;zph?Qr3gILDLnQ+z-O%GpC{~zpRJalGTbHZabml#ewV&>oI(L z;IZ-hcmkK7&S z7Xf*U-ifM#TcA4Uz4wCF1fX@$?b3@r09hikb)7h?-Uqx*+vEq}^H7{nl{(mM)_rYY z%$spY{eBeC9Rrs)X_0}ZLD;k3t{le)wPvo8a-IvYU#|Y~;W%&9Vbu^6hJk8Hmr&w3x6q9>o)dI%~^&p8j6W(6;vDi)@% z-U5k-`+6fD_niCQU&nqWJ>Rxy-n@3c z-SOHL9Cz^E`;z18S`T6H7P0d*C=Yze01|y1~Wv;fQtDXhWy&f%FK0g4++3lk{j`%>C z%BUk2N{aAlX@-k)(tIclJpX*Ws}4|}u6VQI(Ip@+op|shX)RRr49v-WxC+Rf!)1&U ziLCdecuDs6GF+w~yJ56@oGiP&T4M5673g|lAAfp|WBX}Bv`RA2-6plJtsnrSKyIGx zx)Hz}N06SW$pq%q$xcbbf8h6-@>IQdtgh~MZgs|d;!A4Rh_f4T; z%9WJRk1p`!z3Hy|$I^kEYJc?SHZ!0ua+*U`8w3?~w<;%pT?CcxYo9kv9f<9gYTQFv z^;QE&FZ1V&cQRqWzh{cZ#Q>E=3i?v}3_ovPd_YuuSFv)ynQ$y;`?rW$6Kj(rU?7%? z_L2gnD#%~qU`wj{!TKFvhZ$Ud0%cP3IPpQbN&R&z)h=vzH3tH@?NeFy6w&uRP*Hxf zl``rLRBl`=zeB$ZO5!b)CKD$BIbiC+t>>sfPaorG)Eo%(2?^6f$^)RSKc*K%Lpz7&8?`VD@!~tju2tOy}L*`a2)s_zl@pOwzU=v4`hE1g$S&j>=TX zc1&csiAfM?Ab)eg#Q~7Nc3IdH`2xtZwHljxcqioMyIcBQmV-itFQy)s#}X&J)ajlP z*h3side9oJl#HJ@FP=kjgPIb88WSf7q{~=R`9p@S6PaDvrO<=gf-}IL{5m zXDGf#@d5IKg7G+c;Fsl_H?4zmhp^_kYiHu`3Hq}}eTU!t9jhIFcVQ11_kU1)fZAac zAEYI%8)RV825iDVGjb<%hzN7hWsCX?*#na zpN>^`JuBT$ufzSFDg(1;qr>HKnP(TA=YDkP+~4eIRpce2()TIzhD%T2*jdZjL{7Uj z`HL;`hl2XVWd?mI=Xq7uW+~TuXyNCWt@@c`7mVwhe(Rs0_nm6_!GC`GIidbB`aPB7 z6=XZLD{=eNoSntFPO&qE6QASfBVebft1ACwrxiZ`Mk+Nab(HN{)uLzN8_@2zQA@Mb2C-%7(C#CXl2 z16k*u)vKkKeu-y0wj@T9`qdBfpu^F@FPngAIyQtf&Jvi{G<6>=cfjpYpG;TemQ@Kv zX>YfgTCWdaeH5_tb3lF(iW7(;4q0?|bsh}`f^tx{rWR=;>YY=$^9a?7`8c&~q z+927e*kR^;JrQWFWdUEI9=*q$Zi*w2vOluADJP&teflKl#C1SpYlBs$e3GBt5z+>9 zR+P^6he)qT-{iNQi`<{C0ouxXSzO_rC;uKk)Nz)cYl8IbDy7we_lNH z1+-|tSkwBW1X_~c%wZ4)K}(8w(x$4z&}^RBao$w~N^fQ9>Ms2bReM^zOY_B8@w}+t zqSKe5e5*oY?W1=ryG_{kd}tU{S{HkY(?$XLO0c`C`U@yJU9(Y#b`bkFlCOsiymJ8h z-cc_;Ztul%GPzQl)d2$9Y_SiTd7ePses+A}14WkoUTsh?KLwPkC+d4bNUS)B#$2_Y z29;eGzHWYS8FC2{$4aVxpvYw!y>T z0;sCVhzuP044A2>j3Wj-1lsfY+P$+{;7xS**-IKhP^EMJux8_Mpxs<~WJ5s zeB4%Rm^V;Pz`{#*AA#l|(&hNn254kj#m~xds7zFllerZzLxrf`H}LbBZ99n5ACJB_ zKFb^;S$6X-q87J59V>?%P`u`X+n?kUx7?>WjfblBN{60a*hrKd_;Xk zlt-TRg@AmG@@aC@`0W#~UytJF5_L7RV4uDG{{Hw=6JjS^2eN?uAb&?cI6|(nXbvm> z+Fm=aSsG~eAKS`qWU%~M6F0u+UAKsBMXY!o`^UWXJ}2fzLy@@5$sFrbP#D%Y?#tcz z_*n96YM|cxEl^LKT)%6f4AjmLtB`5ahU#~dUv-_ff;t_kuJF-Afw5p*zDE$t4;eoD za_>$ME8ZS(AWV1M;C z*QqFNqcTzJgpt4Nun|P*{PD6;89^w%0~f7F>qc#ViS@&C&{9(3pwMeNVkdE7&TByH+9cOPhIN62sI_UXS z&9B;CEn~&cE8p)dnHa~42b^2-*4NpkZP!`->Gbg%4-E~${tf97#rxEK@nI&@yns~XXs>Ui zj{2Q~?K^So^KNE}Ln77}I}h}8+b3*K3>n+RXEwX=^KR`}u4Nzn9_ZxD@@qENalThn z*Z`H6<6S0rO~m>a%?&6XwkGmbC|q>#yF~hwjCBgbtCrS9iIbhOfzb8;0Z(z^|vPk$C{^ObWIkTSUqcTDpFhh$q2#q&@!SM6CdVux26yfdh4Fqh5 ztbR?Tl-CsSP@FW=;|dA)uS#tG(-;zRDeef=yFI!#boN|Uzdqo!%9#7W-25&sEpZM1 zcu2u7S+dr}ZlP|LDM-&Ni-bdLeUXwr*_{oO2kUq0+qa4D-@yrpV8az8N5Ohl?< zvVq2wiky&QhL4OvL$p1UV}PN)%ffF|HZWWA)_6VE#(s*|ejxvb-}|T^BaVv7598`_ z&_3dVc}MoH-0#k5f1(NJ@%MOfIXn_;)E$?rLR8JHww8P9kNg{s3z45JelPLjY!C_S zi5#S>d~{?A_ID@_M|q&?yD~GTZDGB4u0C3Qn#X}Lu6@J$_5*zX#*5#mR-6V6$8VIc zbyM{m07{^Q-yS0KTQpsS4RDM+Wk#tBhL)P z=TnSYeR@RbK;L%t2zmTUs4%%H=2xTx%}k?!JeL^W_`-6adyUoKzQ6KK9E4LS`?^#oL#=Tb;=0N_at3sa`OxaW$<~d>%^*!bA!N8n{h=k`jEdoO6o>X z30Tmc9Zni926>(pha`(ap?g_;g!B@U-N?%X^ay#?#3de^A-f!1dr!Sb=EWhw^;Gzfh@Vc<^Z6bVUCqK7RJ)E>8ljxS0HUEc&29^4OKZ+ z)3!IR1IqCF2Mw9KpyJ2-s4H_*pn}Gb-m`Eg&=(tRwo;l3l@j-7WgpoFboue(Q)xq? ze%3jbK0=}H`q2w90r^nfy_%z+2Ijonqs*hgoVA@!y|xRORoNyhB7C8Gtho8u$X!sq z@}0EvwLuUtwrZwD-5~s&(0h&EcTRt_ivp>Wx1C(E<}kLW_m8&7rJO88c?bMG)IXwC zcz@YOs0Xh(o22V=2SJtr%|k`W2U1zzx5zOf&L00HJ-Ry)s;wrCzJ7WIvMZukrRRy# z_E@Z^O!^{DzX;`bvc`iF6%!@if7b!3-8!G3 zC1-%5dQ)-Hffp=$b#}UTx(#SWZXX|5JmBQLM(2$Jn%RotbA)j~U#E5K(NQ9ft5Cc} ze)C?lt%IdkJyPv5w;~{KxL&e*P7%wWO?E1|m4M}ir>6R>lgWevuQ3{X^LIhznt;@j z+OLqc&Zcqmt+O~DpzLhj>!qy-WMYnk$plxR8BKciq}zoZA4KjNc2h8aE!du*_yGH_ zhPAHlWuJoabL7PlSkK7crTbpoce+UzmwEaoj@Xqgb|B;;iqBD8K^(tnNT0XlCgLQ; z#(Rr{`PWD7Y48X8%U7MQLXB(J*0_vQ{BdxB_yF~PQJL1-Y*gV|#5%w0@(s!-p>btu z-!~h^sOx_m|3U3N)g<)P-sQb`T$^mR;^QGBGE@v1wO(l>ouB6rh!_5Jtd5R2yeVA| zYLqfND`qUhaZ0Uu^O>0*B$QXf&jIBNc>NhH=jd_J1FS#AJ)_KOLeFvX22JPi`~`eI zFONVRBQ?9Xw>}oz70>?gd8Kpb9akQ46vZ8=ef#ruyT9MjQ8UE(9h4tM_Jxip9>nt# zc=;XD>iApVpCq!%xjypm=0U}#_sZ*cKgD^k3csr(Zat7==bc9y?pX?Dh95qh(+I=* zA^9FV`hL+C9KRv`Fh=W_MYmN#B7NWz^~jp=NOhBJF4|=0{}JFBI47bETHOz z(yL_O18vEV`5g9j;L1LcEx!of8w+3l5ts`U_@@1pkoxb1sL zjMpxmhDxQ3=;DzN@R6!NVtlXvCSHGWE}nbSY#i-0 z8?3~VOs2|<&NO#9Apx$YBBR!&GJyn<89&q-> zS)ioSq888I4V3tY4x+LOKri>b{7%6MsIx_5y5BH>Mi!sM+-DDzq+uUK3Ks!&k;~ZX zfDJ$+Tq9)IO~!E=)qP3K0n1%LjtHZOjA#e4Whlw=1gl@$_(fMb^dV3N6jrU+EerIy zi!FQua#{T`hoj`x-t6{GdBEXstYf#^jwV$9;W&o16FP)WCX1{Z%CIy7_#k=$nB!-oyQ4-hC^!^*vqVtPIXyUT>DpW)cV8 z7^&r%&2P^t{JgpG+D^_tJbpy?p_}RZL<0TY>+@2j7l57>9=%}22cSoIj6BzHPgu^g z3uI?>d%DOqKO#^SPHBHz;R^JbcaJiLjbc6bzRept{eUvl%IR&nH_$&%C?8)x70SD^ z-epL6$YNaQ+{yBt{RR$e^!6L@dap?4zBtf@(pO&uBqR9Ush;u0rRd zxI}pTmZzWgFT1C%eRGZLhbM@_jq#;+54sj}-m6jD?&0$V=l`Jj2UT)U7Nvc%#`6!* zIGAAkhVnZU49v;q$2f`kQN4huw(`@bZpJCQ`JdSChxmeWuI*upG zXPv42Hh3KFx1xM$nJC$Fx`npTJP4BGyX$X#dZE&jdVS86Sw!U&`z?-HFY$BX=w&ha zxBd@XUsBE~H8&@$Ms|YR5!9cZY``?RnGuQeJHx+qE!WFE3CD&!Ht>CLi#T4n&tjsJ z6I8L{@XqWpIPbm0eu7N%EIPI?)Q_!Z`9GESVmOb7`d1a-C&d)So#eKMRzo>{bgAkY zZob1j6vglSID)62qNoo{t1FsND!uWT%eD_tT6gpD>@P>4R9+asIC~T z@6GD}pgbtbFVJEJuO|#^0g66tdau!DAWzF}4&9*ybc1Qy;w7Vju3WU)*O%45icM;M zihKJ)xgdhb zA17x$cg2z8@Oixa9X=n~nc)3Vy&ivm`^L+1HBoktgG9vCCP*SdM&4W2T03o-${nb3E2-C-!2Rbh{|?X!sDl?|3fPI zSn4Ath3yB$*EI*tm{#}Z0`r;B_Q)@Q*K6DSh((>a86YjleziC(44m(|}W{oN%cR&AxxeZP37-CdCe zO~u@L<&4LAdU1Jy_)M2Y@UVm2Wfe$-hi!Ww9eO~4w`tqAr&4_i_qvp{6J1`6P?mP#N~XW9{%7pr@?z3Y;7d zRr{V*On(&!#WiKQZ`|&%;=17F6K)W2e1P&2ln+Z>Bxbz8?HxDICl25HCWsXVC3E7o zY^NNe><&$v(w8<+oMh*0?&u7WlSYfQda>gAs;uwt8C15v-}5Q*Ahrkg_rmtopzlM^ zKFht1(i@2LN_thU*6Bm&yUMRe=E)L=S8bLLS>*zSr!=fQukYYo_hEi0^!l9XN(i?A z|1cYWUs4jj?%88&R|lWEgUf6?32Z$I!M!otn#Ntj@=(b;+M5p4LCF#yzZEP$R4|jE z@0j<7I6z(crQ7qdI1bedI8?>dKaKVDDuGs3>z591-dvVUt=bPC1}Sat9Qz3CfnHOo z`bymg=v#cYEpXcn%-1OsmtPjg@iqO;98cQ=KY+Hf`1CyEyHNe2xb)%+CXh%)3mj;1 zKwEm(NOf)#tKGZxA-<;*%C_(OZu)Z#dtORd)adK%e74vKzgPS?pOfdg#mh521X`6u zL+0G8@WnlM%G9=voOXJGqcw5lq>B5MnRg(%@Xmp?#lZGIZ^Q3DhgQuPMt6@f=Y6i8 ze+H69X+1cb_mK0w$^I4G^Pb+~*o74#khm}@p1yQ`2jnQey8rTC330?h&HWOpJ@~ou z?gzE6?yhd7-h>Cq+lD@o*#)i(W*sl>-3C$fJne~8CH8gW^AAaI?B_G{A*?^>@zv$~ z9e8;3!fU32HTdHxKAM&8fa}*Y%FzB>tQ`725g1Vy#(3EiwetKnzKGVx zdWs~xjXWQc3yHmVVzo&rP(4QSN?__npno6s1~#}>9)7yiE_4wDGT()7 zlWN9x7H9B^aZhgw6qN4Jrj7}RFUwT)P0;rvF4X=i8g_f#UbzmU{5y}-x*)Og_o+Tkpn~DEdfTw^M42bO)s~bj?sKe22G8RjQCpRkL+Z3i)OIHyXnk{a zo5`%%konBkOwT)L;_F}I8^Ed;xT~ech{TA^2+Xj3-No!wcy3;mJz0#V85;YXW9o8FznJGaXgwLn>M2vqOna_%w-+w>)q?4Uj^YI*blAUK*WhHIO8&{u%^B729-2C-L z;`|l8qa!aZCCVtfDPB*=fVNkAv;9t$LCBV&3T{SE;b7|86$RSL(3+vC@i=M#|RGcJ^ zy>))_q2%L0wjFRWf8hvpUE*lEjnAU1OQAVnOkGIS4)FL`IN3&O6n@T}^Og*PiaDm_ zHOht%cy;JxF{@;#W=zxZwm$$lCl;%{81|Fr-$d|rCrQ7lNSKrc!Nj|Tmx@&3$JuQs zo}KfDPD`E1B`c$#OSiszucQuq>j`^4q%;eP+VtlPUXzOTlz3*?hWUQCAh~tR#&4aM z;Z04Xg$qpqNJQPI=c~6t<=yQ@hJI~$9(~0e?Q56R7qj&6cFd!d!N6GI`X+qsG$4-I&7SD|RkoU}7b-U9PO z{ERCXP6G3in(fnxIS^v>V@lqsZ$!~MQ*Npg26I1O6N%s77Q*BAQt=%`$=1v5lBR1Q zZs8Mx*m^nqy%B2mUt8VkayWlJot4soOc^qnbD?mX*RTd(L}7lJZ7+;KV-`s%s%D zw)aHX950StXNis{&ZN`5iVf|to>FtRrv7|70aB#a`zP#@V~_7K9oXYPR=Y!-rY+#j zAGr=BIg26sDVab{-F|*Z`z2DP{@==`4LrDA>L~59l*q=)In@5@^{U z8Zv(j!1_k|LH#h^{5qn#^w^V?oU2&4z zpn72M_VaKCA9;Ersx7sCNRP}XPMtHldUv-v*3*a6!>Q{eo&dR6mz>yh7Aoiti!W?2 z#PfX6bFK;`z0P};gX44hgoG{ky<1svMN0clzlT6MUM1^m=K<9#>dYTC>a+E&9;mh+ zXp!%;zmsKgTtc&!j9om?o~TpOsh-`YPZX10DA9T~3i=j0c-JQ!2l~SeGcPFxL6nv1 zcu!gx)Q>cJx~JR?KIFSA?UFKs4`b;&EYg*@pVMCvho${&&UkhRT1F{M->wl09j*mK zDE^-yXO#CC%R8AwIfuFJBOR3CvFaF8FZ=0m%i?gUjjSATq~^RZvnm>7lNWDR346@* zSBh}%qtiB9mk+%ArQ-X>${*Wk=q|!}o^RXI;cc?4xcM+i$oP2pmSKQ2=e)ggCd3Jq z3vZnLoP^3ezm^A`R}K%GmHQZ4C1b*G`sc&9!FxK7$SIP)BE6K?5cZgSl?K|&5i$>ZSnZDGPp5l|FIoOBJ|~EN4``c2 zjy)t;u=~5GX_wL>}Q&7QIk0xvF3J^kr1bXG|_=B9+;@3YIL z*JGjm?IOELImJ+QEstdU&>6}C#x9sJ|twwGxn1juh3 zYkQ*s!dlcyjx-&EfDBp1<1^N>&wFNLsmWO{VdQ=W@-{w6jIr_M#x*MqfGRRLup;C- z_`VVySaYe0Q-9mLi&^^U$?BeI%dOYX2KYSmd%e6p9eq~5!A#@}x|BoUvdl`h@MUgt2j zQ2Y#jzBOiRPWiLqzgmNo$wmVy?0MY8RfaoQN1xG?vSRT167D+5i#Yzk{j0eirUzN^ z7~YGPyUWL>!{|d6K*G<@II-&vN)IBK9Iyr_7g?t zP7cd6w}+eV1AoRo+k?*M#1E6NmqF%pIe!_wd(dd9bzsWD=iE5`!d!emrg!V-FpnG@ zzfr$_ZH)^zgoJmY3ysFjg_;pTj$7}SF9%us!QE3 zriuc|_Xzz|&0)MwsK)b|X{vP#)TxZOnrgKOYC9?iA5*`^(%V|AQ#029qjB(r8(WNl zaeimU?!ildk*B3;YD59%xQ=D#%k$x5bLoa9eX004ApO*j_x=a)!e z{X~-V)_uP=8mjd>I;%G|bDme?ALE;9L_t?) zrsl}5h$=NB2i33FBC7Z=&D_mc$+xE&nOe8+#sOVopYknjPn@r*o_Tgw@k|mh-}}>! z=(u40Fr9Z>p517I`?n~MgyL(oUaY|~ZAkLw9;hAQC8KO24qx8W9<*8Xp!fi_OGNGO zFKSKw?y}pBl7o^{IPYWLl_x+sWO8AnxdCn`*zM5)BB$LeJc`i z@ZqrLv4^wZ=g?7#dr3w_(Ug+SsS|365kU}s1oXZUTFuff-^ zB}8X!^7sO+KOC+PTq29*hhL6;HcGb&m5GDb6&vO(#^;L&{KMDjx#W9E^21Je*R}IJ zIhNHgGjLp)m&czkeR)S;rLdfMAA34Fh4UmpdN{9>W$ z{ICwIS8AO6U0YWawwpp%t(+wcP0n>1Y#xHm729E}Ud2I1dUIFbzLgw%{a~<`lP_In zzZa@{B6l@^k>%v;Ht##e$)8luTFmaxX_Tw!vg7p0Zbvd9E$_3P|FEx|c&2;XQ_lOh z(y5NK?(?(MDNY{W^y)Cq_kL=W@qho2O*Rx(e8PBXHYNF40dHPnFrIhK46Ng>FKlfl zEtR+i^z*h}6NtLNYz`YY^I8sjzQ}O@*%wh9z>TLyT|w~}jvG*!oj+(&8p4V1+N3TL z=dDora9wo~wkO^ZKQDGXRFURKoZ1ozD=sa^@dV0OAbZ>CVy*|D25{phH6sZ3e_D2T z>@Kc<3$f$bSqf41XpyWAH4;8C_Z``$sLr|GGT)c@er-k~203e1;OnCH48?uyyzH&f zr{MHc!x>`c<8i!K`gDJGnOy_USF!tTX$ee7H(cjM)Kua6T~yan0zmnYg{}qU~FxFp@u>%ZeA6UovBXYSb9KYW5o(&ymOIITOzu0miGL+9OT& z@aEf%$L$u16MXh0=HE=^>-|FN+Ra@zREeYPS1Q|(7GQas4ZTImpFeMq-4EQ^Jd8Ly z-YbIHSt?{dDVevw?3rnXpC9YGTV^SafEeQ4k}Zoe@p)NHhUh0kD)+v=<2d)-VXHxu zPWjPrq{jfC*G~Oe`)uKT;vmcVgFTHT&OGsu(epX)&-VCQXqaP4epXh@Iq&JVa}e~w z)6M^K5&9nIKDC)t&iI2xekmu9O3t<6;Ib#-*ukEXVq>xDUktIu^*tsMjJ6a5-(>AEvFN)^q z$8!v-^@*C*}iTpPOC75mBX>ngGz?30P2uM@V+2)qp)&F2r-?Hdb?F7|Rk ztT>0A5C66!fs@}YU9kv~ZydSUSs=>M&-6Yjq}SE1Ty&uj^77p`pOzTR&Ks@GZ~^!} z*)U|~cRiv=^)Q1sV{UNPaU`DD1q{}EaD3N7$ZbEMrT#RReZHw4V=Zy&0acj~Yw7rR zIAAa9FuzfOy=us z{QXknEeoRq3ZUy;xx=An{BhzhF1qTKgZb-COICaJ)IUB;l)oA(_qgMhkbZb}0`5BD z@v-L&IPY_8u{gK>&-nR$r)krZ2QptGIs8l;R{oeh&xKMQBCk&rv`1+4(I_=Zf5#b5 z{Isrv6F=IecA)xVJ7u45KE)qCPdTA5Ie#lF{+ATFw*3QV9K;FULF%vz8v}&n{Z(!3~lpFpsGe_Lepd3Fy^dY>*3U^oa(o^;9(GL&g2FbF%ZDdP5+|i9UUkW7Adc&s z=Bd&F47dP}(+hPQ39+Y#+yNOam&xdtvf| z8&hndIyriMV^RUf&mF0+;OOUowk5~U-5pZEi4T`OuHxj4C95vMXAl6pgwk3fRw~@wwL@Xt8DLhlo;B)%N)r zALizZj?i$P4&_tXf|PiYRtroX4)=m$05*>+U-zHeUqZ zl1p434a|jSm#;Z!c*L@QN1W`8C3qZ+b)=jcdY_lC41wD1?nM&cZ*lwI9#7CX9`|_$ zMGyxM^%~?9d<>0?;c+)ky(g8yC52lptr4F1_j8_0{%Q8O-;43HUUT*1!SBzs^i6-k zY?}fR&*t^zj!)r^{~f8r_jMB~?|7lCNLq~h^2_V`?Kvo0R54pnH{G2>GS&Ud2cgYHw1t{S-9 zbTiH`f3_^DA$Xf|^316LZ}2!?Cs9E)CH^TKa;lf8(a<64SzqascbEwcX6}n+J}GeY znd$MK)6VC|)u87^9Qb_N*N3YtvEA^-{W$rGmLVl@>TzI{a-k-+BX&P|rpGAm_=saW zcN{`(4uAa(FHcu%=``_Fb~yKYX|u6?vfpPJ_vhG8{CFMndFILo(7mav=t0|J6fY8o zi;$Hodh&>bi!%y*stk!5yABSWG^CfWr^4aElUV)xV67YbREHelzW+vKY)9;TZ?W!C zT;}Af(-w2auZvu3@c01xy)cv=gY5^s=cxaI><9fWly^pUSu{V(q&=>LGhVxJ;wxz1 zvucskmpG0d=UP7C{5}=Nc5Iit>k${&?5jAWzY@~7PE@-b^c>!14!bk)=4Q_QyFZ#@ z|I4=TBUT%6{uSwkozI!y_Y&)ibH4?}P@b|siQc)3*PnU7et);$9-@T%J>2|VH8goB zh0igK!{f;8`5Lp==yC4PTusEkmuD~B-#agg6F>T%c7>lEH)pu&l@jMWnA^D-x)3#- zPWFyJ{+UR~_p#b*e3Rdjvx&x{Y#J_`7R>saLjcy~$|cxxIi7qtN6rP#iW;lqzXGhG75lH{qARHGcV9>zBW^ zfB9SIm%nv?`5WCzf&={iwV?iMf$(cV!%QLxpDSQxkD|nn7B+cnn)c{DhA{+>z}2c*$LFXrrtKQ z24K`DEqftPWR*2b+h&i!#N|(8R%xv@?uBCOsd)_(?*M(<_^gdPBY|qK@_PTAr9i9v z3~zgXKxN*gn_u?M1d2zbvOl>C$Zr;2+Z)Y_)MH*#5<{md`l>r_~$ zd7b@S#vfiag>@vC_Uzq>iOW^XvWP!7wf9S0ruJ2DQaQZ+mwJ3ic-?*u$^S@Pri?tp zAy3gn25?rcS6ffG{&R&PP_1Ti$~21^-`h6viA{Ckqd6-pXeOUH1d7_7yEsIUO1;LU zwmmHn?fkh+O5YA>ovECaAn5uf$u~IHL)WERl8OddcHsLWIl2$CB(C0es}azs4y6%^ zw)pdE)vuhD+vvPvXXbC;EA>%19#XMv&6cdlo6 z*k9uEzd3RFOv(=HTe${*Braon3A(vYt@j*I-f((XP&L7^U}jqbUg3`Hfxheomw3!0 z7%?Uf)^U_j#RLgNR?dB6!67hHtruF3Qb_~`2e3R6Y8DSz^J0$?B=YW`>RiV;50MT& zM6Y^r$%lqlIHDEzB;IuqaTyVt@rwJZn9RB#J9slPr0|Lmvg*7(pN^M!1~r-ik5;o?7s4^mA2l?&@<>NqJys7ZbPf%@ zi9c`Ixr_beSkE(;Q%2_@zenrN`bLx%XT1;QT>T07H->cU-tie(|=l9Qu*SdXL9SH)OW}b&H)(s*OL;>L{ZW&8M^U^}vr=!T{>OP*?1vTxPGx8mcHJL|jJgdhx)_^l@*lVd651 z8<>Hg?Mow**`xyF>~1oYHYrhu`X2?FnbB~6{c4~U9kg^&bOib#8w1&s`9M{U(0=>+ z0nqG2zAZZ53uN_;Q|-+c0wc$*)i3TcJ`WL>^Ar{?nVLYt@j=Bw_kmWKBjMBJ7}r<6 zru_JT(U~S2Bdcp=^(xL-ld1G5(p6KARQzDLT{lbgtPt5cjlaX=ghq`nf%J^y|UJN z`}4f7SI7QtHB9gG{wY7Sr^05!%9opRab6{>(~LKs1JF>G%R<%N-Yvj65)M#f#6!7n z>&erFMv-R{yPih`33H_GtN!bUbP>~j6_R{E^OH%XHuECjBrE>rLIP=&dOY`{r!(2A z;}0R{UodQ~xJ;`q3DHRTaPtDI{XSb~jt%zwpafPvF08Vn?W0drP6KK<`&f}|%*`>6 z|4z;>cI)o=*x^_QT?>BIsV$qaCUs_S9C zvoOEm-DihOmi{0iJ@m)T%lG+iKOS!{_=(!njccR@R>#vknDLiPe=JG=1F}(7Ao`^9$qK4t%=kXjH~XzY0#{Ysv61)v;~q<6AA~@4sPs%v2DBA5BU(E0sG- zFZgKZ#5*9vD}>+-lyzvXJfqOpi8mcMW&RgS%FAOJKTqw@laIKP{UrM;_@bN@cDNFt z#?ybpFtAD95&oj0Poub1xjh?Sp~98P*Nin*bk1$MStCKj(Y9fwDf%4Es6k zI-R_u2WlPozn!iXZd}t89403W$fPMbVQs}&djI45%uih;%7yI&{+h1B6 zYq9nQ(@_a*q%MC<3#_D;YK^{S%S#>1f6TI2AH=nusw}*kNkW;1R9O0X5K>6vUW`yID!m*EXaouwvC&AwH z(kumFo(ChGG&nlXN7DqfMD_;%Qt-BBfMZXiRf{j4t*U9X<27dw6Yx7L;|6XWH~d^l zsu`1rl-=VX`$?PJioUK|Ztc0hQ+zOT484yd@*O*K-;;gZ)<4JR%!*n|fz2?pO zLHNFuf@JH`_hMnP`lVM80ri7U_pQ?3Br582eb_jV^U!1e_Mj-(QsyH63moG5koEJv zOV+5nkd0q|`PnH(5228aZ-Vk>s4GQ9lYvz<1xSL``n;Cx81+4`D#GTVDJTElDbID$ z;-Pf`rUDX=-(BOCJ1wDVa?3YfzJ(`ML2^IoBxL&YicbOEiij(zYv^$6aE0k72X&KC zL!}-1i%o8=;3ah}z%Ah}*$eDZU&XT)h%14l%VdCm>o`lT&@|kmNQce5rx;D>xI>9H zt!o>YmRJ22uht}mH{2uh1QkdmX(nru<~|hWxxBviHqB%HIO6sPj7Jh=RA)&QQs_Kg#ZdJy1s?eD%Uo^x2_2emtf#V)ULG+my} z?arTqojCZK^ji<<8dkv1 zTa3YJt)3Sxn@87K++}i2*J3R2_ScTtr7n0`s=w+^(03K)jsq8rvXjmDn8o}~+4Pj8 z>aAn$a@z)uPS9KQ_j7RqE@Yr6oyFsXjmXF$)8mXU`(MmXN1Qy$sMD-Ym=?C9#I&i& z(yPsat9CUyruadIkp`|;LyJO#I7ktiC$lR|TtaoSa6v`B>BN`kW(3L7kKV0oLTnVL zuQ-Jk)YZ(*BEhi>!5w17yMx!;H5WOZ$rKyE*PEi>=)XuzS1`LnImi#qW0L;T`q z!~5ySZ)R^D;DTYU5GM}sb=8c?`#No5s;pcI-iOnwycp?xze|`(G}5<19b|fWAW?n0 zus$3`dJiQ*6v)x4bTdh!IePPsbHuNg7B5U*e=UgFF&$QfGyyI8JVAO7Rw93~==DPX zOA{M~s5l@l??ByX|0oGryIfsRMFohx`0xC|Z9SPg=TzuExjmiZGWH*FkP(Mi!TWC%B@$>zP9=uU18o=2A}( z-mvuXW>az7htE80vSBpL3xg-xs|mTyd3PSSe6HsnpuFoc8u_^X_pIE?;ROP7a3R+X z&%Ye8reo(z*1xENc2u9LnXvbUieEh?cq(RQU@Y9s@Ol8XxS&@3@}bIv_s_iM~zy+0LI9kg#r{e9$GuZ8)F zVT)fCZp}&$$c`QwT%wFh?4tbPaVaTr{6P72Jm#^q(+XktO?vQ+iS##(U&wuf0n;ec z&>`K&)eQ>iQiEIh;NP(F6-_$#G9)8eC%5gG3!Y}QJ}8J5=N>GZ8DtGr^Q zNT)3ei)x~}cMb$mYMjap!Gk-p^9Dm1Q%fN-C1Cq+6D$SoLFU!;9~lHk4OA|=%%8nB zVITE&eaLT>(+9B;onP|4)^OHzQ{YDJAA|!>@xu1VdC#QYr{{m#D9FOsbYnK(X8ZV% zY^LA7oI?MZrL+i-|Ih8&0t|`6;*aDOr}RF;iahA9StTrn+Fo*YulwW|4QE-oX}k^5U8B~Mh`5J%m|QW5l9J-CTzuW5QQF8y zUkAVI=mrlNRdxX8Db;LR5btnI>w_OyW#>wwV#%xNMZobLPEwyrgT1q(+m~>6SS<&P zM+a5_Hg#RIi3k<%eM-YrfaT}XW`DcbSry2-8*mJs?c*m*;Esvh82+?_1!3@8E`ShH zRaqB#3>IB>Mws?-8Ctw#5=A=?C*a>hgv&Chbu+~p9rzHxfnUT52f5QhpDUG3-M=@> zf2(GK6$8w}5VUi4_91zCRP_FNOtO)fC0sDD)ih&Qoj~2B^+ws7|55Ob3f$fDxM4vz zYjqB?0WSuXuSH*5XRBliSIl;&6m$y^Qlw9rvf90LYwj1)DUUXA+#87x%UPbCig@jW zO$3_=KNW9?dq%vm8_&1QQh!eve~9(8+x?&2LW_bni3QpD?085ron6T9N`$tWvodKj zYug~knO_w%pRJ=Kd_PEhll^JsyO;SNV|fmksg%F2X5UU9%r!b(&c>vPGEFW$;BtQuPc;nMI!7sKzp zcmZl(zxh0rpZyi&{Ybp?;oa=|*0)VnU$YQlZ>ZhGc@#}X{Uk1b0-@_43hwyE>EG>l zQ@CY1pYfg?b&cC}x+?ibK4fe@7BH;#iqHlQ;eE<@Dr5{jF4=F$=nn^fwm3Sg;avTt)U zB$}1%d+w>m7;1{Me2s!lFJ^f!8hHqSGSh-2=KMUkv*|aa<Q~Z|w^m{s zE(GJ|Qv6~Mv+wDI!`PvJ8sKYFLZ4K+u1T6Fjer(f#B!Yy)(O{vdcm%k^_MQoM0&Rw zejV74oYlRuTH8ju9GnzPYj$g5Xnpv}9$B{x;O{%kr$gz^8g|6gtoi$WxV4yqrPqJ$ zl)oc}Db@+IDWFGYbj3b%16n+CFM0v5*5-rh{(NFa4Q!NBsuF)Sz_l@f$UN0n| zymCx&XWBjZ!}Y{*l9O6&M|ZU>^2}}xHMsCICX~E&ZPFAF$yfWv+EWEu#k88#Aj zbRvJY*m`td-NZHHgm-uDYmF>fItUx`A#Z0^Z2xY(>?iuexi6>{X1ig!xBPv+cwV<> z!`YTM%!VAwmD5C&K(0kLy~A8|7CH1>+_C)SF-$_JsOYeCg_OGdCK0U8*w)|ESd51h zQpHnf+iy<7o&51Ed^8k&6wlu*K6E4G+}e0^JCIJ<8L}z(`$*59b-YKAN6cOn73Ie{ zHnK>2{}2O(h3Um{JhBoSIRHGQ$c<@=(_h2W?@dUXlc)b>enddDvSP2`f|A&(l%=>x z*rgN@>q#St$5z|1QDDsOrK!%(6r|kwr)8mbPu?_E_({Lv2~zp3*ose!+@hR7f$%n^?o6;9wja>>3!aFrzoRmO$LPz1q9h$KRmeUy1@|e z7&m9W$LI3G6@sJEgF1L0XZNq**dNxQ9OceNQvHNLOnHZ_QcUqrpoPGB$40`o{BOw8 zZ>54Gw6SqH7(x&&%okzz!A`&Wgi-3@k=>lGO%1FC`v5z`u9ir~zA7zM5bJDw` zF7vZ5aKn}BdwfyE^$LHbFMfS1C#8sIy0TeGm0KE_V&ww7uDrGxQcz|+X{fL6QsYw` zT8i|EXeCCFp?&|S=+vFdhJG|w(d4Vbg6!mq?I(rl_U*4~UVa}3!;y}dIc~AGVb3c# zCRPG2NLWU_~);M$-9$$Q{aURXzEbZPTwt39=!( zZ-J`L^TF$&s=zQ7m`xL`uX$k^@CgV@N&KhTUUDG1b(m+vxd`)mR# zkVaZB60FYMqDP2hUiJD)?pYoyfu!J`xr&rZF`7SoHZJ0!GfbW~x zh02CYvy7%+hR30G=cXVe?g-v?r7FEA1b3DC3 z!A>t|jVTjUH|U`T{a}Ok6Q#EwZ*o|?tdJQsn#Wt8`|wWokNL*%SkJIhJL1nET-K_l}KMGi&=A%uEOOt z5CfAiI~dXKF>>|9zTl@vi-`^`acl{*^Yz;Mo0Qsk<}YIHE5e-KGS!~vNwFURizs## zOQ@@e{&}{IX|$Y;M68&6c0wDdn{0kFa8G#zx{_VQVs7p8=OjrJFr}t&MnGs<{)zF` zIS1G^7Epa((Aytt+g8YaF4ObE7HP_9zp(8?5fMYK}B{yEv@ws0_4w)bb$x-BKSQq4UX4K@z7!_O_a2`KM+(tZr1>w($f$gDYnFdF??HVDiWz z599H7pohb4E-}uzVB#g`Rhj4~!sg$=nDPs13cLwVZu|^GQNG2HC>UqY=6dO;bA;fm z=0(vZ@!1pX<5`dlKlQu6NJ%h=obUFQjqkSoX6?EYNVopKKDR*9=bRK!$d^Z7_7?Sq zBV&KNA=@D~L1t&95F6p1R^!Gq)us_a^;0DfJ`ifnGHts}!rOYerR*{pkN-Z3Idf73 ztaaD!8Y&Fw)Scb)J6VlAPvlPA*xEI4$!}}GM&g;h_A zw#&#`*u(@k(e&823nYa>-zu7H?uo0dghG*zBsw;d4^h`K0vTWo*RkTo7xeujzHv`v zxUcrpe$2WluBBAK@OAsiM6;VbWTP>;+C8Q21T`zFA4`1jHvbnhNxgIOPecR*ewg=!)so18u#sU3w=08CK8z+64Pz+MLJjBBA4mJPlIjWt zWe#P5@CD&N7&H!kzR>=VEM5EeFAXTv$-_Hcb7K2%-A zE~3cPkg@Yk%I>OdFBD?4Led`z#_%^WF@k8*(SR0CPxyBOV<0yda`69_b>G9?JJxp7 zg@~aFwNMIw2h00f7i|12wY&GPnVUE+BKL@R0h=}mjRc!8iruC(1y!y=U=$K5H39n_&LsHr8$td@RIF`U4Jr#>4#{C#f8PqyQe{h^&KIGiov@7KYu$faS6H`3os)=2V6?!8eDXd2Lhj?(BQ+2)Cp}`CLq}xr1C4_ zt9>DAoGj6b7IH6mcZ=pV5sSwl@8>UV@WkkywZs4xdX@wNGwNg;{h(3DS$pgGjk%3b z3Gad;sZT+%uc>t|mu+%;Y4i0<3eTQQ@N6q@`IVK5TQ6PsOTgE0UZa9qrFK6GKl>w6 zNs??#Iv;P7OVHZme79z?+0Nm|(swh1HD>@p1qDLI;Z-wa7q-=2)&xQlZG@UJcvS;h`4!IJc)xX(#FI8dan8_H|b}zzq<>tw@ngo&= zZjKn)gcGEOg|uoZ3xdT{yBlT1oeYG=Z!qHLVXwD^NB3tgt=qG;4@_vkX9Z$O(Vr>g zQ0+l33Q-*6`?Pi2SlikM~Usf!Jgy-<2p|;o80NS1vznVJ&jA9mpck^^5T|8hgw~ zeyk=%dQ2_;ZpwRhi@=HEmB=9b4T|_gS@{z85~$z;d*#tbax5l_Dg87wDx(YaZMFFI zJh7zqg|2-+W$WUC>XhJlf>le*lXXGL=)(ETYtox19el05QSR^8(4&nji2t-n{%%*N zqB*FGKfKh>MzEWQQeEq!GzOSxTgC}>b~9)-pLQi)cC*d@pBBmYGe$Je&3+TzAJ}wu zF(!U_;tjSt%V*;&_F^DQpCBRPbmdIYelODP{aJ&n;+t$R1x0$LEt>N=Ux(cM)81>R zUyA3EGyi%XhqTI;y!<$9Qc$H#B*`ZIV5?JIw$?y1VwjG#>lw*Z}L2%V5hU$ zzw2Q7jd|tN^M}7)bIRTZlvdKh+*HthHhEk&Eu@fsy$QJ1v9{~l*j&0?tIX5ln*!Wn z9c6|Ft@mH_nO2jgJ9GeB-dw-P3HP8Z6g*rA>RXAEOBcVcwInCbh}Kg}6J11{09rby zg}-y8>T|byPN!h343Lk0ohJb^=c{FM4JOZ+TxjHl8;2hMfe(EPEdLuE4UUb%vMvhh z8`MG9U%X1<_Kdk9>9!lu@_d&_5gd5x|04=DPV#(?(MR#5tm!Sf$*fbs)aL7PWOkAB zXIR6Co2`6{5Nkk*5N`69ck~8=0`Y3fNHVKTcLCSDTy29xmw9Tdj(gLbl#+X^lO(4S z=(IXj8j@$w&jkLuZ~?Nq-{1CLbU!13TJ`(;JAZ9?rVu*6X>9v0N{f$$(xJ_UREH>2 zVx5JV7U~wcg?2D{2S527cNC@iMA#J*P+@0=#Pn#|980*-x5}H+I$TeMSrwYGo%-{! z((LFbLsW51E;)BFLrERfvnTC_vOfHA!TI+@LSyJL%HKuMw1;0 z*CD>&glyBk{8{2X0!5x)rP{`TZX?LgpIUSWNT0h60zeOf>rPpQ>H|N$j(oESv}B}I z*zhe65c_HB{htkQDGmke+^%cQqY>^fQY>m}jNmL`;;@pw{^??+Y1Cr=<{pn3Mq_Qy z{&RkU+)_lOlu{xc>(@lX!%oZ#Sh#FJVe|gn+r(sAt^WQ`BDyxqQhrim$iVzbToJYgOnk_SGJjQlrCe?Z&O$^55tg1IV5x(PV zTYu9vGJf=Rl~tlG+HqYIu=5ZbzbU)S2?sS$aHQHFHQTG+1o}y~eTJKD(|oIpZ@ps)xcQuzBY{Szx%vv%unW@BEcZ~KT{<=xf%F)ievSysvK(}4>#rNn{ z-#clx)bsxIC~Zn*P){Y#3~#!?Euy<^(qR8sAp&o^O3o?zO5K#|;X3yRf2GR#3Z}35 zXxVJAiE>kZ$L6HN)A{Xuo^Au;-_zOyWVnp-89jg4(4~=`R@~wr8_KVX5n5~qor9KMZtmnPx}v2H3*URL>iKSePt)vZXM8Tj{%xikvai zZZkJ{P7b15Bp7;M2C>k5o`wjx%O5P)G8wo{aX@-{RXnhC&am5uDte19{%xTahpQ?itLsHyG<)s$fQ84dWvM#t)Dw^9$4yRo2L%Godb zbVnOPyMa5&ZuE=tIDW*H{AH#Os~p+99-j_cNWV+S8@6Yu|2k}(JN72R{w}M%a>L+H zU%7Vgpz>yBJhadP&oM-#gRAE92r(=$!`~3B;QMs*xBjwWacM|uS8X1z zk)N;Vo5LRVGOWm+FKxO0LGvO!;0|mD)J0zHevaK{T@JC267e^@wPdnp##p)V7U7q7 zF0>iaoPFMxj`a4*NdY*S;luHrH(kx5oCtC94S%d@BrN66g>qRF4JMbN_SJFr#uH2q zx7b0XK)VoGm3!T5GuY_;ug=?*?dI#DCkN}g^;;@h+#;w=Dt*zy?>vyJnIKN-6HJJ2 z)Z+v5iPl`|mP%=&^&6bLh{Y(mrb3FgH{UTIG*V|v6skiveXqCgfI2+7uu+z&# zJ??&1;HG3)Pbs)t{`kpBx_HoHd)b^?4c;K3qcySY0nUzN18Dp3W_~u=u+BLGHMtHZ zzTfU^*Fb;ueDVN>qo0}`d=oIc$L{fT^>C&J494GDbXD(Y4tn;2w>j7`b_J*TGyiHW z>ti1TA&;zak~gTwiS^vAgqfOgH&5@!)u-#Dzy$N_k`J7$oVqL&#eh{V08kQrRT$U-6Q6(aqF zfqlJ=H}gtg#|X4G3{ijou>Cn6{CT4gFIa$4Eh40JNiLD;_GI8@cFmA8)u0+{Zm- zaQ@oFK)>V#Rn`4^2j04*@Q2rh5KoVyLb%q^T=Q@7r<$*)I;~Z#ubSpSyRfmQ9m)yr zI#byMoS(!NIDn8Wd3W#K3dvG!08+nKIk3R&xO z=4-hNb>tQ{=-I14$%VMRum37{B|~rbAvU(#oeAkmD3R(a^4z zHIZs_A-mbgcaHCG1>x?;H87 zV{BI$%HIXN>0Y7XGGgTBk-RZxSsuG)+Na4> zbiCQo?9H2N90yNVME@te0($#cL18Uxq`xrQ>-z$V*S($rVKTQ-qZwKpdU`aG)vcKv zx=Ewo3QpNz>d!ObSWd%L#V<&$I5Ins;R~-?zt$R#{x<@Kf}<9TL9$!&MMa z%EZMaM#0&KtQR=fv$<-wTVCN(49fF2hwt0HUp)dp8V(c8@p>Po?v1$QAMmgj+WX5+LEgu^}*yRBUOIx7ggJV#X{_HIRh0%P&_ zzwtsPjB&a#G7YGtdX(*HE}mffv2wpiS}-#$cW%xEo3*UH%G$zrYOWJE(!UH&6Y)Zy z>W^8AHS>R*hrxHrug?6`rkLa4`J?o0v92~7BEny&R+@YJ1aFY|@@G2wuvBj>z^tt@}HZ=;+)VV*XHqigmw%{kEs_jR-Kow|KTFN#z!6gEA(eVY_7lX z?00w@UtPQB+HbyYhfbp5rBa@6`{JNv=(PeTFc#DVC)cQ^s5g^KCjn6G^O=i2H7^FE)3 z9&<)sgZE|{r?kZVHp)L-R2lj$Hmb8&OJaN(R)GVN4FjtmtXsa+K2b4JU( ziXR2>Yl>5kmi&@uG-UQG8| zI*W~I)JML3c&f%?;BCdJb8*Q%uN&aMBuBxla~~`>_}AgMBu_U*U#p1c6*Dyo6tL4_ z@%P96y&(y_)I5s))n1Z9j|JxE3|lwNC(={wNj@X)|uTjj3cTp|J`l?m2?pBBWC#c zu&}O%%l=2QrG191m!{4iO@v2qYGeCg4MQdJ23~ zN1+cxAvb8h8-U#d_?VHQCm*z@iJ5HF-z#2}u50tV#>4Ojy5@&?U9#j7M9-z> zH%Ll!FXFq$R^p?gX;ma~>6hyMqEnQY2wUk5NNrx)Jx=2p40orrx;jtgC~O|B9yKgu zsH$52ytx0SaAOl$N^ZKlmi#FK@y)J%T-`|U+}K#UIa0`N)bu6M7DUo$0)H8GO+Vhkk48+9>bb;lT> z$Uvdz14(h*C72DadjSy|cc2pLX>);7WIy^zoajr|-txX)pwdN?P*F0NFL|=9kGp2# zOfAU`(<+$gs0wr`nh!nXe*MiV4KlOnDsq=@rcjt=BCWS5v5kc(H$u;=*uB!bAo7ak zzD|lP$#YW+uI9<_?_0;3fH6+Omsf3Km(lV!E!SVVi8L#oiwD`Cxw};m9_S@E2}6Y% zC!(Q_WKm0Bb=3;|%J2n#37%5J=Pm;V+B<^uOMu!!+>Mh23&h{N;l zABBE#!%|B%U|Mfe5Zk=M>UwWH>kz<{!qDeIr{J%C0xuZi=wK~}7MA2;ZSsWkys5gD zi$ZnO31HP*KFPLH=%ZvW8svVLMp_<(`J0b z(H_?d`veN<(?;Cx7xUhq($0ZtyWAipH@j7#-bdN0+mT_c4s_UTZhcS~2)s|y? zBLf0%KDlIbTyCS`-h9cisIy<;tBQqTUkZ|cs3_f`$gHvMB0`s53!kEnPi&M z`K4|1Q7UA?&GxSydUDXZBGc#XCc-dn*|phk-@fjl%?KMww{&&Ex#!Yc&V}%3Wa{2f z0OvBOXV8-c=;mH4iw@Z!E6C4cH}uOoL$g!4h$2*}1^^bxgJ1xPKqm0DQ$A_KJIgP7mT3#`z2;P;TXOO(46+f6@(mpIV+i=g z8vVrQQ2K;BPQg(c7{>8;>|N()1VG#xW9_)3wDUVj7wUa7$wf_U^y;uxy&xj1! zyO;QA-1m1(bZ=tTM6}Anjg#mV8WFBXr`PL0-FjqA|KjZkkKlKSdoxyV0uiS1Yv=g2 zKP+21|538;u?cICMN>lz6{oDlwW_l_@_20RD09%fP z_~1=|=LP|QaZOK4G3&kDNPyT>smiA><$R={ohUBR*T=pHfkv+>?8*AyU2c}zTi%o_ zp!2e&Je|Iax=D`PWK#=CDmgj7=fEnp8~E4DErH`(w7KL<6TgJ0*Z-TGwR3c#nM0+6 z%j;~VHBsYJVBAv1+wqP>eIhx?%3R0tmmrH|v7q7CE;l`@C{1N}B3rw4QL>z)T2Ax) zC8Lg!zK^|2ft=Ex<&H;(zFNmzUQ5r1@6mk<*+CJv}zJmDv+j z?XEGHq_%|3R$e?|CQ(_ zDZVTKjZFEDFyj{T1w$ho@H4cS%CE3CI?}>j#&XMIH+ToP2ddB3#!YMoZ+A5V+SH|hUI(js7QtL>CcFO++{!-QC!I+*hWL3x+3kn8Y| z@U|@Lu~o0%kD9fuWm~4a7^Oum*7QP5mJ;^-P^x$Fsi5}6Ecg6pmnH5hUwV|Hxq)IXj zmflI;j$UfydIg|h^afbvKR>v-G<>rqyrjv+sZP~>kUazNeRf8FML8j^&YqzL{XX?} z(ib@m-IS}ow-dFL7aX}MSnjtA1CTb`l-t>LJPkJ3Pih4VF5jeOxM?_#LyO}1)IvQ( z10~LrOLGp!Ue|c1FRE>BQBtgB&OS=i+js!9(-#R*lqP)T`!4Q2jP-BsyREXafHX#{ zf%zAzd_N38&#zm@H1(uzg&YZwd0(Iw7)^W`2OEw1MI51a7VghY59f{1FLf)}%tUG# z(*`)WRr+gf6MW9pOsJj>oII$sSIHT!BQzJ21p_!_tUZ&7wx>5>X(g*o^W5f&0FOuU zY}?XRrfw5p3R91K^kJ!rvg5kLdq%m@FJx{(#K0ujDMU1!@Mh0vJo`Zk^gxV_Nh5Ug zYc0P~k2%gjd^nRce=zQw8P|3i6>^HIjPs8g7Z-8DlmGm z8d<8fQf*<$m6ZUXpNaEF)xTu`v~D7@nBOcd6LMBmCaGCd4^Pw9Jl#YLKy$I@{ zGo^$jute{t>s5|DM)>@jGAFpd=Ul&IIdkN~rQk{YH|#8pBfWm^(S!ABlrW!WHGb8O zS$IncZpOE$I%61X2J5W>(uvCDJ2#D^W}w=MkU+@7ci4X2m;FnF;&TU4Z2=~CG>LO- z;_r|mj@4LN3Ri{gezCR*k0UAGQ@(N*7Ecp3_#DvoBM8~^D^M4G2|K~h1 zDi*%t^L)&wpp!J@6Oc@#Yo~ZsrR{k+)&DA1hbiM(T`)*H2({15f!VNq7 zn4JgqI0|N4J&bm3+GDplE2{l8I%?FOQW6vJi{eL?Yf87j~-e3%Lw2O1An-p*yB6t>>Z-wfc1S<0sl65F1ySE-;`7Ct0H}Cf=Ia zN7Vh72gc0A5;)_?_k8v_9pT7mPAuI&9+-<=cvhde%zLRZ1)J#IU*2PeH{tC1j1uUJ z0Fr3r)&9}?5>xo3oR{5WqKBs8|K^18#pHSPyC7UXu#ocihMi2*1g&IVa=Oq1qda;0 zI_$sJ@ZMtY9xvs`bM`7^cJ@GE;*8M5t^iUHhR-))?G+{9Ec|yc*ak(Z;(^)nhC5wy zJ;tx2J8iBMz+J1S=wU2-PkW?&boVPKUYn_=v~zm6)%AJ5HhxtlJ>_8vU_CEvU2D)K zzc_yEN}sHXI*|sA{zLw_u6f(N#N$HRP|vDQ-*^0Fcu`mr#MY<)$a28$Z#=|j`la5g zQGq}a7Z`p;Vl**|UY0atfpChgN9hh~$hfTGo#=S4nNz#hIjyyZk#KSNnHkb_tb+F@ z;{jgK85u7lD|18-zqAuA*&E~4D5Z_^SK*;Bn{uJWE2zLW1t-D@;3t&5BU`plUf>61 z7R~y|o`EG~^a5SMs-PZX-HVyo&Bu$N*Wb+&T7Y`B)c-NhOF{9?|C;87Wui#;(2cCh zocZIfc_R=?&>udi>Hc8;)w7;F+r{P*#&al^q<@W*ROdSJ>e*z-*-8ub660T1T-{7W z+z6E0^7boGxKv<{UoViyf)1hk{>1kGGU5cEYKxVXOyT@;7 zyHF0gNfSkOQUXJ?iPbC9UCy0a?XAIZK@PX?G3nlD0$l>t)q!Vb1Ck$~$%vcES`Fhe z!%yIN&1bTrmzGKHcYiv*D>w(Ko7e_xPI_)KMZrP~MG?`Kr_8~=DbsNU4(nsx0f4biF$D~ z&N`qexImO-I-XpFy~_z*jDUMIIeoeF+Wq->kDnqDZF-#Q@82J0d+a9NLjnR; z;WmesFF=_&sADJLX@HSa=Og8Ylc*YUve8*{afwtgT$%N3zaY@E^=^0@J^v8Ls@m3Q zn)ufkLHBGgITRovO%E-;tuyeTS)_>2@@@QX4sV>z(U?4I4||cwpL!M;L(i&iQrDU# ze0{x5nE~O^+x9JL&h2$C`Y=y8>T_@SQ26(h_V%8;&HO9JYc6l>C291-OmUaPs`EH`h=5cbkK7)`e}++wSSlyIoAH&Zi;L`u6#t6A4fR>m zguXw-FHVy*3ro6`W{u0w834UW+-}DCc?SCz&yPgG%oyDILl{|Jo7^8LO}W}t(6fNM zhyI*EDz%^hx**Cy*>d=%4KS&_L0ncz%`(XvCUr}EbH3)d z2SIj30I3Ma*KKpxDPjQ0i@B@FI;P=T_lfdSkNxix+2mPG4>9X2m2BEsn}mCJ&LY1E zZ%n>V%in%p5Uh{aF`Qf(w0n*-g4wx@sXxRGEZ+P&<|Gx$+=+}dhP*0(D*f5a@wDtG z7*k4ZZj~Q7a@XwZo6E)~)OETYO{Sx$WwE?mz|`V%53O#v^lkITu+dq|4m zt`Va5NKHx>zP13WU8=yBKsEe7vy;MxprL$bFj`e!U|aH~%jO?w-~UybtGruo94VKy zRODGVP1lwDh=p&8&>{YJ1^FP6@1Jw&r;jtZM;J`}O@7>}{;KLoA_E|%NEk)UUfPL% zynt)gQdIAHgm;KCN*Ro(z5wpKSMW_=Y1$KCNgZ(%%9I7Sxkv`H-lC@Z<5CLSpl^3i zX0nyRlkU;GNOX)nqh7e}H57a$yi~7<$OCk+Z<=gM^lu{8fRLWBJlo45GtSQRYShHlZhOE6xd0uCG&UwA&|GDq`y07nY-QV};vt%`G)Z#_aNKEdt-NhIozQ}0i z!+FL{_i^A%$UpZ-$lf{OasC&+{Ex49%_dm;heUST%%cY7E(8Px=QB&(Uxj%b?@0Pu zyOtNIO~rUV1=Jr0_53J&mFrrU&V{)q1UjOVX;g;}o2?G?Y7?B`{q)SQa3W?SqGK!3 zrPB|4EMhIPlR;7%;ag=#lx47uN**C6;8UvG6y9@VF*tI0%AAwh z>iy;ktxQK>eayAdBX#Oy`^Qa z&(zLDoN_U~es-SL@MWvvgl(u=JD7kLLsWRm`Fa7a3TpF0O@mLZkbK9jIcz@AA-_YLsQ9P(aFcJFN?!i*)S^|_1=WQGR|=WJzduMg%_HwdeF zwB3Cauq8{l_>pBf=uNfs__F1t_{gI>AKY*`_|?#Z4FEvHdPs8^Jf=WB`tVA5@ztIb##tnE$+pVfl~&&WRAqb_U9%C!g4UnRtxK0TGWGQluX z>X?+X|H%x#@l@biE;M?*LezPV<`%%-Eh-&QeB8U&U*U8b#}!>mXm3bG@bD-;@7*(* zq)jkB$t|vm6)OJi8h(<=ZdsT#nj`ILLt!7h^$&{{p--EgvEFk)^CM=f2grckMhgsF zA7G~4P3W|XJif9D(`5(QqggL`G!zOda#zPkEi#Tr7gN^$yv+Z@Qw54CK^`u>=2ql) zkLirzqobGA5o5-UOL#^hz6!d`n@MB@KA`_SB_rk@1go(W1()2-=}X&nx>ZqJG_cvqfB_@keepT_(iI3 zh$~3b0-D52vMR`5{8>{!5(AxvYCfh8x>t;@yJoS;k@B-2Qjsy46Fp#E@2@|&x9jWx zc%{nbBW{cJ&cg4Ib#{yuc?q8jhfyY+C%{?Dms9WS=1+f454eVgQ&ZokX8O;A0e1DK zA5oVk93RE^!cbBjnc7Jy{Ob%W0c{T%D-CPQ{2Z#~jd&pg7)JA+lWUH+H&_d;9!sgf zvNo@tFmg-Ep+{rFvf|%S484u(T8u*PpJpr~#`?6qbHjr1d9`0}=Z?-;mZLmk2-Q2L zALa>4!o~93s&#`Yt#N`+0#9`_Yxv!y>aNEw`F*pzjMIU|J(z*FPUX7@fDlUE6@=!Y zy_4E*>=5TmYa^(p8?muFUy3Z++ZZ{$j7SJHdU@^gDS(;&-v%R5x3qcdM7WlV zB0t`cFr-6eB!I$P5}6HH|0dYT)!!(TZa!n#&D7dCbZ_{4$eNO0!9=V)YFQ4PgA8SE zx~N%L{sH2t3yY}ZrYOCD2wxNXlwO!JIOsH}H`59yo`_o1XbpGecaLGH zcP0vG<4o3L^7@VmA~UD2f^ zuVTkfiy)mYvdMSVz2O8$NcyS+3yYZ^^17dQul?1~Ebw44jxfhM5`2mCKrjA!hkx{3 zhHh?p^Z4dV){ZqZ@93iBeJ_v`W51=JbuiHgaitKu#ckp+bZvHs^wEgU(^s&rc{#Pm z1w5L@9-5=6HVHfeVZcH|z>ab}Un}Kv*KZe0A7*Z?%)B}d{xI=1ownw-mf0id@j`6! zlJkO>X}F%z#bU(hE9ZSXIC?2ETW}&o&qn#u{xmI5ss38&O4n70?>rW1BYxy}Mf9=o~Y;GcTi_V8n~sQc|N3+z(F#5IvUW7|Sft*yxy zMoMH36@Q)n{33pNdRN=ax;tN77r9bN{$pkl1(P#UxChN7fyfN4!6sey_Q(^ z|Mrox)mdnp4w&fymFjXNcUVehsiZfhc+w^GDg$}a%fd5!fdu3cXsxZ&3T z4!-*TVN(I+!DiFB+&+Xas+lN>Xd>PJwx$r^g*fsK1$a08Vieh`7-dRGX{Uoqt-psk zwRdjMeq&|*cztg*dMC7cJ5YCZxYvdc4hx*+m^&rKeLEhXF4b>a;N!=!THO;?c-a$* zyt~g(#9BU(mkNUU-bA13!}ua*0jOP*Tym0Xyj>}d?djpPiKDlh_7m3z=9X(m?&>{L zuaZ5t(r|7vEY1ank_j7=cXj^9o~$g z*J<$HE9>ha5* zvcGGiPLz-HT4wJ3IbV}AdqCP5WH&rkyXYFGJWeN0i{$=vf$Q~d34%u1{bvxf&qNzu z(K$x$*||t&`K4JEG%@6Astzaw7qllm_9{kLSZ#D$X1L=E?rh&R|HfKgi#w?>9|}Io zXBpH5>#q9$DOgo_hLtuSpV{M4&_+wPM~I~vR=~Y)N*LtcQGODXCnnl}O|Rui``|XT zS0Mm7`Pnbi++TKpS;nZ4jM!01fDOiSNXvja;hWiqwE>cxLI1^yi>vQA8xIH|v}_iE z(9%-vnLAn#4&x6Zoj4`Na~2}J4+aKM2;_VV0|=s=^4ZcTCKhlhJr+5XnVO|s@P7VS z*VjnnM?32XmEbFR+8|<9L1eeWsA|4|^Pgj0e~Z32e&FyRoiD z#v~*vRT4|W$qBNDq|07e^EU7gBdYjVZVoRPjc2^=YMXshy0J(nOV=JtFSXqo8{kNZ zcgOccy)A0`-FZt0uUO&4(xSMOGu0gHayz-3@axwB=$rFRyWdMMr`FMYQt=Zv(M_O1 z{%^m7Lul@{E%4k|Sj%>$xVe8F2PkOXdf1g&LsAoh!)j9uQ@Q-fp z*ogj9{+qa{ne)5X#rtyYE=guIJlDCOQLYXOm2T58>xwI*FAuZZz8HUXGUutUbtmi_ znQ_kF!=<|OvmyCs4E6!^WHaT%(x!tgvm(uRVH-bDcdmxU7P^R)*YnCKjpAX zXoioIJaklK+ODDl*Y@D}M^dgVXH$S!*$-MudjrrHh|c1V12^QTq6LJlxMNJi#bth_ ztQRqo6#J=aTbDIWPa)lFxJk*X7H5V|*WHC<=D$6Y2YdV$;`hOnS=Ra2ie{~wd&ylR z`oET?+!l)aApOce~xx=1~p z7IC4}X4WeklH<}_60)FJz|@=72T7ipV+?{M^G4sVl0-EATCz^J?7Gss&&00x-rs8M z+PNSU;@dQ|8HVPTne=bT<>_IHGv)Ub*&*1Q9US=!YfTT1QEaBn*)If=BZ-v1+qcZ@o9+H7AoQn%jha6I^**V-xYH zOs3sF7NXQ(E&q4|mhQVYGvf6K>!2dGFLHOryy^vjXLk$#xS>Y{67lnoC^ly(2i z?CN3ria8OJ1+M%r#`g1ENq>EY_3)|D8?H$((7))5+_AN^McAVqqzLYEDHFQ-n9bbE zCwajMwkedofrOvAdqmr-J@(;6TG|rO{!U5lAWF4O!1KZF>6=HnBU`Sa)|)gurExaF sN{`i^t4bYt^G2yLo3Wc2=phJ^NN0r3(new!) +# Graphical view of genotypes and allele depths Function `create_depth_profile` generates dispersion graphics with x and y-axis representing, respectively, the reference and alternative allele depths. The function is only available for biallelic markers in VCF files with allele counts information. Each dot represents a genotype for `mks` markers and `inds` individuals. If both arguments receive `NULL`, all markers and individuals are considered. Dots are colored according to the genotypes present in the onemap object (`GTfrom = onemap`) or VCF file (`GTfrom = vcf`). A rds file is generated with the data in the graphic (`rds.file`). The `alpha` argument controls the transparency of the color of each dot. Control this parameter is a good idea when having a large number of markers and individuals. The `x_lim` and `y_lim` control the axis scale limits; by default, it uses the maximum value of the counts. @@ -537,8 +537,6 @@ LGs <- group(mark_no_dist, LOD = LOD_sug, max.rf = 0.4) LGs ``` -(new!) - The other function for grouping is called `group_upgma`. It is an adapted version of [MAPpoly](https://github.com/mmollina/MAPpoly) grouping function. ```{r} @@ -630,7 +628,7 @@ ERROR: The linkage between markers 1 and 2 did not reach the OneMap default crit ``` You can automatically remove these markers setting argument `rm_unlinked = TRUE`. The marker will be removed, and the ordering algorithms will be restarted. Warning messages will inform which markers were removed. If you don't get warning messages, it means that any marker needed to be removed. This is our case in this example, but if you obtain an error or warning running your dataset, you already know what happened. -**NOTE**: (new!) If your sequence has many markers (more than 60), we suggest to first use hmm=FALSE to check the ordering and after speed up `mds`, `seriation`, `rcd`, `record` and `ug` using BatchMap parallelization approach. See section [`Speed up analysis with parallelization`](#speed-up-analysis-with-parallelization-new) for more information. +**NOTE**: If your sequence has many markers (more than 60), we suggest to first use hmm=FALSE to check the ordering and after speed up `mds`, `seriation`, `rcd`, `record` and `ug` using BatchMap parallelization approach. See section [`Speed up analysis with parallelization`](#speed-up-analysis-with-parallelization-new) for more information. To order by comparing all possible orders (exhaustive search), the function `compare` can be used: @@ -639,10 +637,6 @@ function `compare` can be used: LG3_comp <- compare(LG3) ``` -```{r, echo=FALSE} -data(LG3_comp) -``` - **WARNING: This algorithm can take some time to run, depending on marker types in the linkage group. If you are working on a personal computer, without high capacity, we recommend using a maximum of ten markers. ** @@ -657,10 +651,12 @@ The first argument to the `compare` function is an object of class `sequence` (t To see the results of the previous step, type: -```{r} +```{r, eval=FALSE} LG3_comp ``` +*NOTE*: Check the [GitHub vignette version](https://statgen-esalq.github.io/tutorials/onemap/Outcrossing_Populations.html) to visualize the output. + Remember that for outcrossing populations, one needs to estimate marker order and also linkage phases between markers for a given order. However, because two-point analysis provides information @@ -681,15 +677,19 @@ Unless one has some biological information, it is a good idea to choose the order with the highest likelihood. The final map can then be obtained with the command. -```{r} +```{r, eval=FALSE} LG3_final <- make_seq(LG3_comp, 1, 1) ``` +```{r, echo=FALSE} +LG3_final <- map(make_seq(twopts, c(43,22,7,18,8,13,44))) +``` + The first argument is the object of class `compare`. The second argument indicates which order is chosen: 1 is for the order with the highest likelihood, 2 is for the second-best, and so on. The third argument indicates which combination of phases is chosen for a given order: 1 also means the combination with the highest likelihood among all combinations of phases (based on Nested LOD). For simplicity, these values are defaults, so typing -```{r} +```{r, eval=FALSE} LG3_final <- make_seq(LG3_comp) ``` @@ -784,7 +784,7 @@ most informative ones: LG2_init <- make_seq(twopts, c(4, 20, 24, 49,50,51, 52)) ``` -Here there is a automatic way of obtain a new sequence only with markers selected by type: (new!) +Here there is a automatic way of obtain a new sequence only with markers selected by type: ```{r} LG2_init <- seq_by_type(sequence = LG2, mk_type = c("A", "B")) @@ -1013,7 +1013,7 @@ library(stringr) (LG2_test_map <- onemap::map(LG2_test_seq)) ``` -**NOTE**: (new!) If your sequence has many markers (more than 60), we suggest to speed up `map` using BatchMap parallelization approach. See section [`Speed up analysis with parallelization`](#speed-up-analysis-with-parallelization-new) for more information. +**NOTE**: If your sequence has many markers (more than 60), we suggest to speed up `map` using BatchMap parallelization approach. See section [`Speed up analysis with parallelization`](#speed-up-analysis-with-parallelization-new) for more information. Now, we have the map without markers `23` and `51`. @@ -1446,7 +1446,7 @@ any_seq <- make_seq(twopts, c(30, 12, 3, 14, 2)) (any_seq_map <- map(any_seq)) ``` -**NOTE**: (new!) If your sequence has many markers (more than 60), we suggest to speed up `map` using BatchMap parallelization approach. See section [`Speed up analysis with parallelization`](#speed-up-analysis-with-parallelization-new) for more information. +**NOTE**: If your sequence has many markers (more than 60), we suggest to speed up `map` using BatchMap parallelization approach. See section [`Speed up analysis with parallelization`](#speed-up-analysis-with-parallelization-new) for more information. **Warning**: If you find an error message like: @@ -1464,7 +1464,7 @@ library(stringr) This is a subset of the first linkage group. When used this way, the `map` function searches for the best combination of phases between markers and prints the results. -(new!) + **Warning**: It is not our case in this example, but, sometimes, it can happen that some markers in your sequence don’t reach the `OneMap` linkage criteria when linkage are estimated by HMM multipoint approach using `map`, it will produce an error like this: @@ -1506,7 +1506,7 @@ Removing markers 3, 4, 5, 12, and 30 from `any_seq`: After that, the map needs to be re-estimated. -# Speed up analysis with parallelization (new!) +# Speed up analysis with parallelization **Warning**: Only available for outcrossing and f2 intercross populations. @@ -1598,7 +1598,7 @@ rcd_map_par <- rcd(input.seq = seq_all, overlap = 30) ``` -```{r, echo=FALSE, eval=FALSE} +```{r, echo=TRUE, eval=FALSE} a <- rf_graph_table(rcd_map, mrk.axis = "none") b <- rf_graph_table(rcd_map_par, mrk.axis = "none") p <- ggarrange(a,b , common.legend = TRUE, @@ -1634,7 +1634,7 @@ record_map_par <- record(input.seq = seq_all, overlap = 30) ``` -```{r, echo=FALSE, eval=FALSE} +```{r, echo=TRUE, eval=FALSE} a <- rf_graph_table(record_map, mrk.axis = "none") b <- rf_graph_table(record_map_par, mrk.axis = "none") p <- ggarrange(a,b , common.legend = TRUE, @@ -1670,7 +1670,7 @@ ug_map_par <- ug(input.seq = seq_all, overlap = 30) ``` -```{r, echo=FALSE, eval=FALSE} +```{r, echo=TRUE, eval=FALSE} a <- rf_graph_table(ug_map, mrk.axis = "none") b <- rf_graph_table(ug_map_par, mrk.axis = "none") p <- ggarrange(a,b , common.legend = TRUE, @@ -1708,7 +1708,7 @@ map_mds_par <- mds_onemap(input.seq = seq_all, overlap = 30) ``` -```{r, echo=FALSE, eval=FALSE} +```{r, echo=TRUE, eval=FALSE} a <- rf_graph_table(map_mds, mrk.axis = "none") b <- rf_graph_table(map_mds_par, mrk.axis = "none") p <- ggarrange(a,b , common.legend = TRUE, @@ -1758,7 +1758,7 @@ batch_map_par <- map_avoid_unlinked(input.seq = seq_all, overlap = 30) ``` -```{r, echo=FALSE, eval=FALSE} +```{r, echo=TRUE, eval=FALSE} a <- rf_graph_table(batch_map, mrk.axis = "none") b <- rf_graph_table(batch_map_par, mrk.axis = "none") p <- ggarrange(a,b , common.legend = TRUE, @@ -1774,7 +1774,7 @@ ggsave(p, filename = "map.jpg") As you can see in the above maps, heuristic ordering algorithms do not return an optimal order result, mostly if you don't have many individuals in your population. Because of the erroneous order, generated map size is not close to the simulated size (100 cM) and their heatmaps don't present the expected color pattern. Two of them get close to the color pattern, they are the ug and the MDS method. They present the right global ordering but not local. If you have a reference genome, you can use its position information to rearrange the local order. -# Export estimated parents haplotypes (new!) +# Export estimated parents haplotypes In the older version, users could only access the estimated linkage phase by observing the print in the console: @@ -1800,12 +1800,10 @@ You can also obtain a data.frame with a list of sequences and personalize the gr parents_haplotypes(CHR2_final,CHR3_final, group_names=c("CHR2","CHR3")) ``` - -# Export estimated progeny haplotypes (new!) +# Export estimated progeny haplotypes Function `progeny_haplotypes` generates a data.frame with progeny phased haplotypes estimated by `OneMap` HMM. For progeny, the HMM results in probabilities for each possible genotype, then the generated data.frame contains all possible genotypes. If `most_likely = TRUE`, the most likely genotype receives 1 and the rest 0 (if there are two most likely both receive 0.5), if `most_likely = FALSE` genotypes probabilities will be according to the HMM results. You can choose which individual to be evaluated in `ind`. The data.frame is composed by the information: individual (ind) and group (grp) ID, position in centimorgan (pos), progeny homologs (homologs), and from each parent the allele came (parents). - ```{r} (progeny_haplot <- progeny_haplotypes(CHR2_final, most_likely = TRUE, ind = c(1,2), group_names = "CHR2_final")) ``` @@ -1817,6 +1815,53 @@ plot(progeny_haplot, position = "stack") plot(progeny_haplot, position = "split") ``` +# Export to [`VIEWpoly`](https://github.com/mmollina/viewpoly) + +`OneMap` output can now be visualized on [`VIEWpoly`](https://github.com/mmollina/viewpoly), an interactive app to display results from linkage analysis. + +```{r, eval=FALSE} +viewpoly.obj <- export_viewpoly(seqs.list = list(CHR1_final,CHR2_final, CHR3_final)) +save(viewpoly.obj, file = "onemap_viewpoly_map.RData") +``` + +Check [`VIEWpoly` tutorial](https://cristianetaniguti.github.io/viewpoly_vignettes/VIEWpoly_tutorial.html) for further information on how to upload this data file to the app and how to visualized the generated graphics. + +# Export to [`QTLpoly`](https://github.com/gabrielgesteira/QTLpoly) + +You can use your built map to map QTL using [`QTLpoly`](https://github.com/gabrielgesteira/QTLpoly): + +```{r, eval=FALSE} +# Only one group +genoprob <- export_mappoly_genoprob(CHR1_final) +str(genoprob) + +# All groups +groups_list <- list(CHR1_final,CHR2_final, CHR3_final) +genoprobAll <- lapply(groups_list, export_mappoly_genoprob) + + +# Read in QTLpoly (check its tutorial for further information about pheno4x object format) +library(qtlpoly) +data = read_data(ploidy = 2, geno.prob = genoprobAll, pheno = pheno4x, step = 1) + +``` + +# Export to [`diaQTL`](https://github.com/Cristianetaniguti/diaQTL) + +You can use your built map to map QTL using [`diaQTL`](https://github.com/Cristianetaniguti/diaQTL): + +```{r, eval=FALSE} + +all_progeny_haplot <- progeny_haplotypes(list(CHR1_final, + CHR2_final, + CHR3_final), + most_likely = FALSE, + ind = "all") + +library(diaQTL) +convert_onemap(data = all_progeny_haplot, outstem = "example_") # It will generate the diaQTL input files example_diaQTL_geno.csv and example_diaQTL_ped.csv +``` + # Session Info From 2bad25619477cfe51645abc6b852c222c3264a26 Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Fri, 25 Oct 2024 10:46:09 -0400 Subject: [PATCH 35/36] changing f2 C and D codification --- R/codif_data.R | 354 +++++++++++------------ R/read_mapmaker.R | 656 +++++++++++++++++++++---------------------- R/rf_graph_table.R | 680 ++++++++++++++++++++++----------------------- 3 files changed, 845 insertions(+), 845 deletions(-) diff --git a/R/codif_data.R b/R/codif_data.R index e41e5c2..7393744 100644 --- a/R/codif_data.R +++ b/R/codif_data.R @@ -1,177 +1,177 @@ -####################################################################### -# # -# Package: onemap # -# # -# File: codif_data.R # -# Contains: codif_data # -# # -# Written by Marcelo Mollinari with minor modifications by Cristiane # -# Taniguti # -# copyright (c) 2009, Marcelo Mollinari # -# # -# On Decemter 12th, 2015, Gabriel Margarido included codification # -# for other cross types. # -# # -# First version: 02/27/2009 # -# License: GNU General Public License version 2 (June, 1991) or later # -# # -####################################################################### - -# This function gets the input in strings and converts into numbers -codif_data <- function(geno.in, segr.type.in, - cross = c("outcross", "f2", "backcross", - "riself", "risib")) { - cross <- match.arg(cross) - - geno.out <- matrix(NA,nrow(geno.in),ncol(geno.in)) - segr.type.out <- rep(NA,length(segr.type.in)) - - ## missing data are represented by '0' - geno.out[is.na(geno.in)] <- 0 - - for(i in 1:length(segr.type.in)) { - ## based on the marker type, convert strings to numbers - if (cross == "outcross") { - switch(EXPR=segr.type.in[i], - A.1={ - geno.out[which(geno.in[,i]=="ac"),i] <- 1 - geno.out[which(geno.in[,i]=="ad"),i] <- 2 - geno.out[which(geno.in[,i]=="bc"),i] <- 3 - geno.out[which(geno.in[,i]=="bd"),i] <- 4 - segr.type.out[i] <- 1 - }, - A.2={ - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="ac"),i] <- 2 - geno.out[which(geno.in[,i]=="ba"),i] <- 3 - geno.out[which(geno.in[,i]=="bc"),i] <- 4 - segr.type.out[i] <- 1 - }, - A.3={ - geno.out[which(geno.in[,i]=="ac"),i] <- 1 - geno.out[which(geno.in[,i]=="a"),i] <- 2 - geno.out[which(geno.in[,i]=="bc"),i] <- 3 - geno.out[which(geno.in[,i]=="b"),i] <- 4 - segr.type.out[i] <- 1 - }, - A.4={ - geno.out[which(geno.in[,i]=="ab"),i] <- 1 - geno.out[which(geno.in[,i]=="a"),i] <- 2 - geno.out[which(geno.in[,i]=="b"),i] <- 3 - geno.out[which(geno.in[,i]=="o"),i] <- 4 - segr.type.out[i] <- 1 - }, - B1.5={ - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="ab"),i] <- 2 - geno.out[which(geno.in[,i]=="b"),i] <- 3 - segr.type.out[i] <- 2 - }, - B2.6={ - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="ab"),i] <- 2 - geno.out[which(geno.in[,i]=="b"),i] <- 3 - segr.type.out[i] <- 3 - }, - B3.7={ - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="ab"),i] <- 2 - geno.out[which(geno.in[,i]=="b"),i] <- 3 - segr.type.out[i] <- 4 - }, - C.8={ - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="o"),i] <- 2 - segr.type.out[i] <- 5 - }, - D1.9={ - geno.out[which(geno.in[,i]=="ac"),i] <- 1 - geno.out[which(geno.in[,i]=="bc"),i] <- 2 - segr.type.out[i] <- 6 - }, - D1.10={ - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="ab"),i] <- 2 - segr.type.out[i] <- 6 - }, - D1.11={ - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="b"),i] <- 2 - segr.type.out[i] <- 6 - }, - D1.12={ - geno.out[which(geno.in[,i]=="ab"),i] <- 1 - geno.out[which(geno.in[,i]=="a"),i] <- 2 - segr.type.out[i] <- 6 - }, - D1.13={ - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="o"),i] <- 2 - segr.type.out[i] <- 6 - }, - D2.14={ - geno.out[which(geno.in[,i]=="ac"),i] <- 1 - geno.out[which(geno.in[,i]=="bc"),i] <- 2 - segr.type.out[i] <- 7 - }, - D2.15={ - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="ab"),i] <- 2 - segr.type.out[i] <- 7 - }, - D2.16={ - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="b"),i] <- 2 - segr.type.out[i] <- 7 - }, - D2.17={ - geno.out[which(geno.in[,i]=="ab"),i] <- 1 - geno.out[which(geno.in[,i]=="a"),i] <- 2 - segr.type.out[i] <- 7 - }, - D2.18={ - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="o"),i] <- 2 - segr.type.out[i] <- 7 - } - ) - } - else if (cross == "f2") { - switch(EXPR=segr.type.in[i], - A.H.B = { - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="ab"),i] <- 2 - geno.out[which(geno.in[,i]=="b"),i] <- 3 - segr.type.out[i] <- 4 - }, - D.B = { - geno.out[which(geno.in[,i]=="b"),i] <- 2 - geno.out[which(geno.in[,i]=="d"),i] <- 1 - segr.type.out[i] <- 6 - }, - C.A = { - geno.out[which(geno.in[,i]=="a"),i] <- 2 - geno.out[which(geno.in[,i]=="c"),i] <- 1 - segr.type.out[i] <- 7 - } - ) - } - else if (cross == "backcross") { - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="ab"),i] <- 2 - segr.type.out[i] <- 8 - } - else if (cross == "riself" || cross == "risib") { - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="b"),i] <- 3 - segr.type.out[i] <- 9 - } - - if(any(is.na(geno.out[,i]))) - stop(paste("Invalid marker codification. Please check data for marker", colnames(geno.in)[i]), ".", sep="") - } - dimnames(geno.out) <- dimnames(geno.in) - return(list(geno.out, segr.type.out)) - } - -# end of file +####################################################################### +# # +# Package: onemap # +# # +# File: codif_data.R # +# Contains: codif_data # +# # +# Written by Marcelo Mollinari with minor modifications by Cristiane # +# Taniguti # +# copyright (c) 2009, Marcelo Mollinari # +# # +# On Decemter 12th, 2015, Gabriel Margarido included codification # +# for other cross types. # +# # +# First version: 02/27/2009 # +# License: GNU General Public License version 2 (June, 1991) or later # +# # +####################################################################### + +# This function gets the input in strings and converts into numbers +codif_data <- function(geno.in, segr.type.in, + cross = c("outcross", "f2", "backcross", + "riself", "risib")) { + cross <- match.arg(cross) + + geno.out <- matrix(NA,nrow(geno.in),ncol(geno.in)) + segr.type.out <- rep(NA,length(segr.type.in)) + + ## missing data are represented by '0' + geno.out[is.na(geno.in)] <- 0 + + for(i in 1:length(segr.type.in)) { + ## based on the marker type, convert strings to numbers + if (cross == "outcross") { + switch(EXPR=segr.type.in[i], + A.1={ + geno.out[which(geno.in[,i]=="ac"),i] <- 1 + geno.out[which(geno.in[,i]=="ad"),i] <- 2 + geno.out[which(geno.in[,i]=="bc"),i] <- 3 + geno.out[which(geno.in[,i]=="bd"),i] <- 4 + segr.type.out[i] <- 1 + }, + A.2={ + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="ac"),i] <- 2 + geno.out[which(geno.in[,i]=="ba"),i] <- 3 + geno.out[which(geno.in[,i]=="bc"),i] <- 4 + segr.type.out[i] <- 1 + }, + A.3={ + geno.out[which(geno.in[,i]=="ac"),i] <- 1 + geno.out[which(geno.in[,i]=="a"),i] <- 2 + geno.out[which(geno.in[,i]=="bc"),i] <- 3 + geno.out[which(geno.in[,i]=="b"),i] <- 4 + segr.type.out[i] <- 1 + }, + A.4={ + geno.out[which(geno.in[,i]=="ab"),i] <- 1 + geno.out[which(geno.in[,i]=="a"),i] <- 2 + geno.out[which(geno.in[,i]=="b"),i] <- 3 + geno.out[which(geno.in[,i]=="o"),i] <- 4 + segr.type.out[i] <- 1 + }, + B1.5={ + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="ab"),i] <- 2 + geno.out[which(geno.in[,i]=="b"),i] <- 3 + segr.type.out[i] <- 2 + }, + B2.6={ + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="ab"),i] <- 2 + geno.out[which(geno.in[,i]=="b"),i] <- 3 + segr.type.out[i] <- 3 + }, + B3.7={ + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="ab"),i] <- 2 + geno.out[which(geno.in[,i]=="b"),i] <- 3 + segr.type.out[i] <- 4 + }, + C.8={ + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="o"),i] <- 2 + segr.type.out[i] <- 5 + }, + D1.9={ + geno.out[which(geno.in[,i]=="ac"),i] <- 1 + geno.out[which(geno.in[,i]=="bc"),i] <- 2 + segr.type.out[i] <- 6 + }, + D1.10={ + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="ab"),i] <- 2 + segr.type.out[i] <- 6 + }, + D1.11={ + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="b"),i] <- 2 + segr.type.out[i] <- 6 + }, + D1.12={ + geno.out[which(geno.in[,i]=="ab"),i] <- 1 + geno.out[which(geno.in[,i]=="a"),i] <- 2 + segr.type.out[i] <- 6 + }, + D1.13={ + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="o"),i] <- 2 + segr.type.out[i] <- 6 + }, + D2.14={ + geno.out[which(geno.in[,i]=="ac"),i] <- 1 + geno.out[which(geno.in[,i]=="bc"),i] <- 2 + segr.type.out[i] <- 7 + }, + D2.15={ + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="ab"),i] <- 2 + segr.type.out[i] <- 7 + }, + D2.16={ + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="b"),i] <- 2 + segr.type.out[i] <- 7 + }, + D2.17={ + geno.out[which(geno.in[,i]=="ab"),i] <- 1 + geno.out[which(geno.in[,i]=="a"),i] <- 2 + segr.type.out[i] <- 7 + }, + D2.18={ + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="o"),i] <- 2 + segr.type.out[i] <- 7 + } + ) + } + else if (cross == "f2") { + switch(EXPR=segr.type.in[i], + A.H.B = { + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="ab"),i] <- 2 + geno.out[which(geno.in[,i]=="b"),i] <- 3 + segr.type.out[i] <- 4 + }, + D.B = { + geno.out[which(geno.in[,i]=="b"),i] <- 1 + geno.out[which(geno.in[,i]=="d"),i] <- 2 + segr.type.out[i] <- 5 + }, + C.A = { + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="c"),i] <- 2 + segr.type.out[i] <- 5 + } + ) + } + else if (cross == "backcross") { + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="ab"),i] <- 2 + segr.type.out[i] <- 8 + } + else if (cross == "riself" || cross == "risib") { + geno.out[which(geno.in[,i]=="a"),i] <- 1 + geno.out[which(geno.in[,i]=="b"),i] <- 3 + segr.type.out[i] <- 9 + } + + if(any(is.na(geno.out[,i]))) + stop(paste("Invalid marker codification. Please check data for marker", colnames(geno.in)[i]), ".", sep="") + } + dimnames(geno.out) <- dimnames(geno.in) + return(list(geno.out, segr.type.out)) + } + +# end of file diff --git a/R/read_mapmaker.R b/R/read_mapmaker.R index b898b1e..a9e7ef0 100644 --- a/R/read_mapmaker.R +++ b/R/read_mapmaker.R @@ -1,328 +1,328 @@ -######################################################################### -## # -## Package: onemap # -## # -## File: read_mapmaker.R # -## Contains: read_mapmaker # -## # -## Written by Marcelo Mollinari with minor modifications by Cristiane # -## Taniguti # -## Adapted from read.cross.mm (found in the R package qtl) # -## copyright (c) 2000-6, Karl W Broman # -## # -## First version: 09/27/2009 # -## License: GNU General Public License version 3 (June, 2007) or later # -## # -######################################################################### - -## Function to read data in MAPMAKER style from input file - - -##' Read data from a Mapmaker raw file -##' -##' Imports data from a Mapmaker raw file. -##' -##' For details about MAPMAKER files see \cite{Lincoln et al.} (1993). The -##' current version supports backcross, F2s and RIL populations. The file -##' can contain phenotypic data, but it will not be used in the analysis. -##' -##' @param dir directory where the input file is located. -##' @param file the name of the input file which contains the data to be read. -##' @param verbose A logical, if TRUE it output progress status -##' information. -##' -##' @return An object of class \code{onemap}, i.e., a list with the following -##' components: \item{geno}{a matrix with integers indicating the genotypes -##' read for each marker in \code{onemap} fashion. Each column contains data -##' for a marker and each row represents an individual.} -##' -##' \code{MAPMAKER/EXP} fashion, i.e., 1, 2, 3: AA, AB, BB, respectively; 3, 4: -##' BB, not BB, respectively; 1, 5: AA, not AA, respectively. Each column -##' contains data for a marker and each row represents an individual. -##' -##' \item{n.ind}{number of individuals.} \item{n.mar}{number of markers.} -##' \item{segr.type}{a vector with the segregation type of each marker, as -##' \code{strings}. Segregation types were adapted from outcross segregation -##' types, using the same notation. For details see \link{read_onemap}.} -##' \item{segr.type.num}{a vector with the segregation type of each marker, -##' represented in a simplified manner as integers. Segregation types were -##' adapted from outcross segregation types. For details see -##' \link{read_onemap}.} \item{input}{the name of the input file.} -##' \item{n.phe}{number of phenotypes.} \item{pheno}{a matrix with phenotypic -##' values. Each column contains data for a trait and each row represents an -##' individual. Currently ignored.} \item{error}{matrix containing HMM emission probabilities} -##' -##' @author Adapted from Karl Broman (package \pkg{qtl}) by Marcelo Mollinari, -##' \email{mmollina@@usp.br} -##' @seealso \code{mapmaker_example_bc} and \code{mapmaker_example_f2} raw files in the -##' package source. -##' @references Broman, K. W., Wu, H., Churchill, G., Sen, S., Yandell, B. -##' (2008) \emph{qtl: Tools for analyzing QTL experiments} R package version -##' 1.09-43 -##' -##' Lincoln, S. E., Daly, M. J. and Lander, E. S. (1993) Constructing genetic -##' linkage maps with MAPMAKER/EXP Version 3.0: a tutorial and reference -##' manual. \emph{A Whitehead Institute for Biomedical Research Technical -##' Report}. -##' @keywords IO -##' @examples -##' \donttest{ -##' map_data <-read_mapmaker(file=system.file("extdata/mapmaker_example_f2.raw", package = "onemap")) -##' #Checking 'mapmaker_example_f2' -##' data(mapmaker_example_f2) -##' names(mapmaker_example_f2) -##' } -##'@export -read_mapmaker<-function (file=NULL, dir=NULL, verbose=TRUE) -{ - ## create file name - if (is.null(file)) - stop("Missing file.") - if (!is.null(dir) && dir != "") { - file <- file.path(dir, file) - } - - ## count lines in rawfile - n.lines <- length(scan(file, what = character(), skip = 0, - nlines = 0, blank.lines.skip = FALSE, - quiet = TRUE, sep = "\n")) - ## begin reading/parsing the genotype data - cur.mar <- 0 - cur.phe <- 0 - NEW.symb <- c("1", "2", "3", "4", "5", NA) - OLD.symb <- c("A", "H", "B", "D", "C", "-") - flag <- 0 - for (i in 1:n.lines) - { - a <- scan(file, 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))) - type <- "backcross" - else if (!is.na(match("self", a))) - type <- "riself" - else if (!is.na(match("sib", a))) - type <- "risib" - 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]) - if(verbose){ - 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") - } - ## 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) - if(any(is.na(match(g,NEW.symb)))) - stop(paste("Invalid marker codification. Please check data for marker", marnames[cur.mar]), ".", sep="") - 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(geno) <- list(NULL, marnames) - dimnames(pheno) <- list(NULL, phenames) - ## done reading the raw file - ## data coding in onemap style - segr.type<-character(n.mar) - segr.type.num<-numeric(n.mar) - if(type=="f2"){ - cl <- c("onemap", "f2") - ##checking for markers with one class (e.g A A A - - - A - A - - - A) - ##they are not necessarily monomorphic because we don't know the missing data - mkt.mono<-NULL - mkt.mono<-which(apply(geno, 2, function(x) sum(!is.na(unique(x))))<=1) - if(length(mkt.mono)!=0){ - segr.type[mkt.mono]<-"A.H.B" - } - mkt<-apply(geno, 2, function(x) prod(unique(x), na.rm=TRUE)) - segr.type[mkt==2 | mkt==3 | mkt==6]<-"A.H.B" - segr.type[mkt==12]<-"D.B" - segr.type[mkt==5]<-"C.A" - mkt.rest<-which(segr.type=="") - for(i in mkt.rest) - { - if(any(is.na(match(na.omit(unique(geno[,i])), 1:5)))) - { - mkt.wrg.names <- paste(sQuote(colnames(geno)[i]), collapse = ", ") - msg <- sprintf(ngettext(length(mkt.wrg.names), - "marker %s has invalid codification", - "markers %s have invalid codification"), mkt.wrg.names) - stop(msg) - } - else - segr.type[i]<-"M.X" - } - segr.type.num[segr.type=="A.H.B"]<-4 - segr.type.num[segr.type=="C.A"]<-7 - segr.type.num[segr.type=="D.B"]<-6 - segr.type.num[segr.type=="M.X"]<-0 - # Adapting to change in f2 HMM == out HMM - geno[, segr.type=="C.A"][which(geno[, segr.type=="C.A"] == 1)] <- 2 - geno[, segr.type=="C.A"][which(geno[, segr.type=="C.A"] == 5)] <- 1 - geno[, segr.type=="D.B"][which(geno[, segr.type=="D.B"] == 4)] <- 1 - geno[, segr.type=="D.B"][which(geno[, segr.type=="D.B"] == 3)] <- 2 - geno[is.na(geno)]<-0 - } - else if(type=="backcross"){ - cl <- c("onemap", "backcross") - ##Verifying if there are up to two classes in bc data, ignoring NAs - if(sum(!is.na(unique(as.vector(geno)))) > 2) - stop("check data: there are more than 2 classes for backcross") - segr.type[]<-"A.H" - segr.type.num<-rep(8,ncol(geno)) - geno[is.na(geno)]<-0 - geno[geno==3]<-1 #coding for raw data entered as H and B - } - else if(type=="riself" || type=="risib"){ - if (type=="riself") cl <- c("onemap", "riself") - else cl <- c("onemap", "risib") - ##Verifying if there are up to two classes in ril data, ignoring NAs - if(sum(!is.na(unique(as.vector(geno)))) > 2) - stop("check data: there are more than 2 classes for ", type) - segr.type[]<-"A.B" - segr.type.num<-rep(9,ncol(geno)) - geno[is.na(geno)]<-0 - #geno[geno==3]<-2 #coding as backcross - } - else - stop("Invalid cross type") - if(n.phe != 0) { - miss.value.pheno <- apply((apply(pheno, 2,is.na)),2,sum) - if(verbose){ - cat("\tMissing trait values: ", "\n") - for(i in 1:n.phe) { - cat("\t",formatC(paste(colnames(pheno)[i],":",sep=""),width=max(nchar(paste(colnames(pheno),":",sep="")))), miss.value.pheno[i], "\n") - } - } - } - - onemap.obj <- list(geno = geno, n.ind = n.ind, n.mar = n.mar, - segr.type = segr.type, segr.type.num=segr.type.num, - input=file, n.phe=n.phe, pheno = pheno) - class(onemap.obj) <- cl - new.onemap.obj <- create_probs(onemap.obj, global_error = 10^-5) - - structure(new.onemap.obj) -} - -## end of file +######################################################################### +## # +## Package: onemap # +## # +## File: read_mapmaker.R # +## Contains: read_mapmaker # +## # +## Written by Marcelo Mollinari with minor modifications by Cristiane # +## Taniguti # +## Adapted from read.cross.mm (found in the R package qtl) # +## copyright (c) 2000-6, Karl W Broman # +## # +## First version: 09/27/2009 # +## License: GNU General Public License version 3 (June, 2007) or later # +## # +######################################################################### + +## Function to read data in MAPMAKER style from input file + + +##' Read data from a Mapmaker raw file +##' +##' Imports data from a Mapmaker raw file. +##' +##' For details about MAPMAKER files see \cite{Lincoln et al.} (1993). The +##' current version supports backcross, F2s and RIL populations. The file +##' can contain phenotypic data, but it will not be used in the analysis. +##' +##' @param dir directory where the input file is located. +##' @param file the name of the input file which contains the data to be read. +##' @param verbose A logical, if TRUE it output progress status +##' information. +##' +##' @return An object of class \code{onemap}, i.e., a list with the following +##' components: \item{geno}{a matrix with integers indicating the genotypes +##' read for each marker in \code{onemap} fashion. Each column contains data +##' for a marker and each row represents an individual.} +##' +##' \code{MAPMAKER/EXP} fashion, i.e., 1, 2, 3: AA, AB, BB, respectively; 3, 4: +##' BB, not BB, respectively; 1, 5: AA, not AA, respectively. Each column +##' contains data for a marker and each row represents an individual. +##' +##' \item{n.ind}{number of individuals.} \item{n.mar}{number of markers.} +##' \item{segr.type}{a vector with the segregation type of each marker, as +##' \code{strings}. Segregation types were adapted from outcross segregation +##' types, using the same notation. For details see \link{read_onemap}.} +##' \item{segr.type.num}{a vector with the segregation type of each marker, +##' represented in a simplified manner as integers. Segregation types were +##' adapted from outcross segregation types. For details see +##' \link{read_onemap}.} \item{input}{the name of the input file.} +##' \item{n.phe}{number of phenotypes.} \item{pheno}{a matrix with phenotypic +##' values. Each column contains data for a trait and each row represents an +##' individual. Currently ignored.} \item{error}{matrix containing HMM emission probabilities} +##' +##' @author Adapted from Karl Broman (package \pkg{qtl}) by Marcelo Mollinari, +##' \email{mmollina@@usp.br} +##' @seealso \code{mapmaker_example_bc} and \code{mapmaker_example_f2} raw files in the +##' package source. +##' @references Broman, K. W., Wu, H., Churchill, G., Sen, S., Yandell, B. +##' (2008) \emph{qtl: Tools for analyzing QTL experiments} R package version +##' 1.09-43 +##' +##' Lincoln, S. E., Daly, M. J. and Lander, E. S. (1993) Constructing genetic +##' linkage maps with MAPMAKER/EXP Version 3.0: a tutorial and reference +##' manual. \emph{A Whitehead Institute for Biomedical Research Technical +##' Report}. +##' @keywords IO +##' @examples +##' \donttest{ +##' map_data <-read_mapmaker(file=system.file("extdata/mapmaker_example_f2.raw", package = "onemap")) +##' #Checking 'mapmaker_example_f2' +##' data(mapmaker_example_f2) +##' names(mapmaker_example_f2) +##' } +##'@export +read_mapmaker<-function (file=NULL, dir=NULL, verbose=TRUE) +{ + ## create file name + if (is.null(file)) + stop("Missing file.") + if (!is.null(dir) && dir != "") { + file <- file.path(dir, file) + } + + ## count lines in rawfile + n.lines <- length(scan(file, what = character(), skip = 0, + nlines = 0, blank.lines.skip = FALSE, + quiet = TRUE, sep = "\n")) + ## begin reading/parsing the genotype data + cur.mar <- 0 + cur.phe <- 0 + NEW.symb <- c("1", "2", "3", "4", "5", NA) + OLD.symb <- c("A", "H", "B", "D", "C", "-") + flag <- 0 + for (i in 1:n.lines) + { + a <- scan(file, 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))) + type <- "backcross" + else if (!is.na(match("self", a))) + type <- "riself" + else if (!is.na(match("sib", a))) + type <- "risib" + 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]) + if(verbose){ + 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") + } + ## 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) + if(any(is.na(match(g,NEW.symb)))) + stop(paste("Invalid marker codification. Please check data for marker", marnames[cur.mar]), ".", sep="") + 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(geno) <- list(NULL, marnames) + dimnames(pheno) <- list(NULL, phenames) + ## done reading the raw file + ## data coding in onemap style + segr.type<-character(n.mar) + segr.type.num<-numeric(n.mar) + if(type=="f2"){ + cl <- c("onemap", "f2") + ##checking for markers with one class (e.g A A A - - - A - A - - - A) + ##they are not necessarily monomorphic because we don't know the missing data + mkt.mono<-NULL + mkt.mono<-which(apply(geno, 2, function(x) sum(!is.na(unique(x))))<=1) + if(length(mkt.mono)!=0){ + segr.type[mkt.mono]<-"A.H.B" + } + mkt<-apply(geno, 2, function(x) prod(unique(x), na.rm=TRUE)) + segr.type[mkt==2 | mkt==3 | mkt==6]<-"A.H.B" + segr.type[mkt==12]<-"D.B" + segr.type[mkt==5]<-"C.A" + mkt.rest<-which(segr.type=="") + for(i in mkt.rest) + { + if(any(is.na(match(na.omit(unique(geno[,i])), 1:5)))) + { + mkt.wrg.names <- paste(sQuote(colnames(geno)[i]), collapse = ", ") + msg <- sprintf(ngettext(length(mkt.wrg.names), + "marker %s has invalid codification", + "markers %s have invalid codification"), mkt.wrg.names) + stop(msg) + } + else + segr.type[i]<-"M.X" + } + segr.type.num[segr.type=="A.H.B"]<-4 + segr.type.num[segr.type=="C.A"]<-5 + segr.type.num[segr.type=="D.B"]<-5 + segr.type.num[segr.type=="M.X"]<-0 + # Adapting to change in f2 HMM == out HMM + geno[, segr.type=="C.A"][which(geno[, segr.type=="C.A"] == 1)] <- 1 + geno[, segr.type=="C.A"][which(geno[, segr.type=="C.A"] == 5)] <- 2 + geno[, segr.type=="D.B"][which(geno[, segr.type=="D.B"] == 4)] <- 2 + geno[, segr.type=="D.B"][which(geno[, segr.type=="D.B"] == 3)] <- 1 + geno[is.na(geno)]<-0 + } + else if(type=="backcross"){ + cl <- c("onemap", "backcross") + ##Verifying if there are up to two classes in bc data, ignoring NAs + if(sum(!is.na(unique(as.vector(geno)))) > 2) + stop("check data: there are more than 2 classes for backcross") + segr.type[]<-"A.H" + segr.type.num<-rep(8,ncol(geno)) + geno[is.na(geno)]<-0 + geno[geno==3]<-1 #coding for raw data entered as H and B + } + else if(type=="riself" || type=="risib"){ + if (type=="riself") cl <- c("onemap", "riself") + else cl <- c("onemap", "risib") + ##Verifying if there are up to two classes in ril data, ignoring NAs + if(sum(!is.na(unique(as.vector(geno)))) > 2) + stop("check data: there are more than 2 classes for ", type) + segr.type[]<-"A.B" + segr.type.num<-rep(9,ncol(geno)) + geno[is.na(geno)]<-0 + #geno[geno==3]<-2 #coding as backcross + } + else + stop("Invalid cross type") + if(n.phe != 0) { + miss.value.pheno <- apply((apply(pheno, 2,is.na)),2,sum) + if(verbose){ + cat("\tMissing trait values: ", "\n") + for(i in 1:n.phe) { + cat("\t",formatC(paste(colnames(pheno)[i],":",sep=""),width=max(nchar(paste(colnames(pheno),":",sep="")))), miss.value.pheno[i], "\n") + } + } + } + + onemap.obj <- list(geno = geno, n.ind = n.ind, n.mar = n.mar, + segr.type = segr.type, segr.type.num=segr.type.num, + input=file, n.phe=n.phe, pheno = pheno) + class(onemap.obj) <- cl + new.onemap.obj <- create_probs(onemap.obj, global_error = 10^-5) + + structure(new.onemap.obj) +} + +## end of file diff --git a/R/rf_graph_table.R b/R/rf_graph_table.R index 0d1bea2..736b80f 100644 --- a/R/rf_graph_table.R +++ b/R/rf_graph_table.R @@ -1,340 +1,340 @@ -##################################################################################### -## ## -## Package: onemap ## -## ## -## File: rf_graph_table.R ## -## Contains: rf_graph_table ## -## ## -## Written by Marcelo Mollinari ## -## Upgraded to ggplot2/plotly by Rodrigo Amadeu and Cristiane Taniguti ## -## copyright (c) 2018, Marcelo Mollinari and Rodrigo Amadeu and Cristiane Taniguti ## -## ## -## First version: 2009/05/03 ## -## Last update: 2018/05/15 ## -## Description was modified by Augusto Garcia on 2015/07/25 ## -## Upgrade to ggplot2/plotly by Rodrigo Amadeu on 2018/02/15 ## -## License: GNU General Public License version 2 (June, 1991) or later ## -## ## -##################################################################################### - -globalVariables(c("x", "y", "x.type", "rf")) -globalVariables(c("y.type", "x.missing")) -globalVariables(c("y.missing", "LOD.CC")) -globalVariables(c("LOD.CR", "LOD.RC", "LOD.RR")) - -##' Plots pairwise recombination fractions and LOD Scores in a heatmap -##' -##' Plots a matrix of pairwise recombination fraction or -##' LOD Scores using a color scale. Any value of the -##' matrix can be easily accessed using an interactive plotly-html interface, -##' helping users to check for possible problems. -##' -##' The color scale varies from red (small distances or big LODs) to purple. -##' When hover on a cell, a dialog box is displayed with some information -##' about corresponding markers for that cell (line (y) \eqn{\times} column (x)). They are: -##' \eqn{i}) the name of the markers; \eqn{ii}) the number of -##' the markers on the data set; \eqn{iii}) the segregation types; \eqn{iv}) -##' the recombination fraction between the markers and \eqn{v}) the LOD-Score -##' for each possible linkage phase calculated via two-point analysis. For -##' neighbor markers, the multipoint recombination fraction is printed; -##' otherwise, the two-point recombination fraction is printed. For markers of -##' type \code{D1} and \code{D2}, it is impossible to calculate recombination -##' fraction via two-point analysis and, therefore, the corresponding cell will -##' be empty (white color). For cells on the diagonal of the matrix, the name, the number and -##' the type of the marker are printed, as well as the percentage of missing -##' data for that marker. -##' -##' @import ggplot2 -##' @importFrom reshape2 melt -##' @importFrom grDevices rainbow -##' @importFrom plotly ggplotly -##' @importFrom htmlwidgets saveWidget -##' @importFrom utils browseURL -##' -##' @param input.seq an object of class \code{sequence} with a predefined -##' order. -##' @param graph.LOD logical. If \code{TRUE}, displays the LOD heatmap, otherwise, -##' displays the recombination fraction heatmap. -##' @param main character. The title of the plot. -##' @param inter logical. If \code{TRUE}, an interactive HTML graphic is plotted. -##' Otherwise, a default graphic device is used. -##' @param html.file character naming the html file with interative graphic. -##' @param mrk.axis character, "names" to display marker names in the axis, "numbers" to display -##' marker numbers and "none" to display axis free of labels. -##' @param lab.xy character vector with length 2, first component is the label of x axis and second of the y axis. -##' @param n.colors integer. Number of colors in the pallete. -##' @param display logical. If inter \code{TRUE} and display \code{TRUE} interactive graphic is plotted in browser automatically when run the function -##' -##' @return a ggplot graphic -##' -##' @author Rodrigo Amadeu, \email{rramadeu@@gmail.com} -##' @keywords utilities -##' @examples -##' -##'\donttest{ -##' ##outcross example -##' data(onemap_example_out) -##' twopt <- rf_2pts(onemap_example_out) -##' all_mark <- make_seq(twopt,"all") -##' groups <- group(all_mark) -##' LG1 <- make_seq(groups,1) -##' LG1.rcd <- rcd(LG1) -##' rf_graph_table(LG1.rcd, inter=FALSE) -##' -##' -##' ##F2 example -##' data(onemap_example_f2) -##' twopt <- rf_2pts(onemap_example_f2) -##' all_mark <- make_seq(twopt,"all") -##' groups <- group(all_mark) -##' -##' ##"pre-allocate" an empty list of length groups$n.groups (3, in this case) -##' maps.list<-vector("list", groups$n.groups) -##' -##' for(i in 1:groups$n.groups){ -##' ##create linkage group i -##' LG.cur <- make_seq(groups,i) -##' ##ordering -##' map.cur<-order_seq(LG.cur, subset.search = "sample") -##' ##assign the map of the i-th group to the maps.list -##' maps.list[[i]]<-make_seq(map.cur, "force") -##' } -##' } -##'@export -rf_graph_table <- function(input.seq, - graph.LOD=FALSE, - main=NULL, - inter=FALSE, - html.file = NULL, - mrk.axis="numbers", - lab.xy=NULL, - n.colors=4, - display=TRUE){ - - ## checking for correct objects - if(!any(inherits(input.seq,"sequence"))) - stop(deparse(substitute(input.seq))," is not an object of class 'sequence'") - if(!(mrk.axis=="names" | mrk.axis=="numbers" | mrk.axis=="none")) - stop("This mrk.axis argument is not defined, choose 'names', 'numbers' or 'none'") - - ## extracting data - if(inherits(input.seq$data.name, c("outcross", "f2"))) - { - ## making a list with necessary information - n.mrk <- length(input.seq$seq.num) - if(inter){ - LOD <- lapply(input.seq$twopt$analysis, - function(x, w){ - m <- matrix(0,nrow = length(w), ncol = length(w)) - k <- matrix(c(rep(w[1:(length(w))], each = length(w)), - rep(w[1:(length(w))], length(w))), ncol = 2) - k <- k[-which(k[,1] == k[,2]),] - k <- t(apply(k, 1, sort)) - k <- k[-which(duplicated(k)),] - LOD.temp<- x[k[,c(1,2)]] - m[lower.tri((m))] <- LOD.temp - m[upper.tri(m)] <- t(m)[upper.tri(m)] - return(m) - }, input.seq$seq.num - ) - } - mat<-t(get_mat_rf_out(input.seq, LOD=TRUE, max.rf = 0.501, min.LOD = -0.1)) - } else { - ## making a list with necessary information - n.mrk <- length(input.seq$seq.num) - if(inter){ - LOD<-matrix(0, length(input.seq$seq.num), length(input.seq$seq.num)) - k <- matrix(c(rep(input.seq$seq.num[1:(length(input.seq$seq.num))], each = length(input.seq$seq.num)), - rep(input.seq$seq.num[1:(length(input.seq$seq.num))], length(input.seq$seq.num))), ncol = 2) - k <- k[-which(k[,1] == k[,2]),] - k <- t(apply(k, 1, sort)) - k <- k[-which(duplicated(k)),] - LOD.temp<- input.seq$twopt$analysis[k[,c(1,2)]] - LOD[lower.tri((LOD))] <- LOD.temp - LOD[upper.tri(LOD)] <- t(LOD)[upper.tri(LOD)] - } - mat<-t(get_mat_rf_in(input.seq, LOD=TRUE, max.rf = 0.501, min.LOD = -0.1)) - } - - ##Scaling the LODs to print them properly - ## range.LOD<-range(as.dist(t(mat)), na.rm=TRUE) - ## range.rf<-range(as.dist(mat), na.rm=TRUE) - mat[row(mat) > col(mat) & mat > 0.5] <- 0.5 ## if there are recombinations greater than 0.5 (for numerical convergence problems), assuming 0.5 - mat[row(mat) < col(mat)][mat[row(mat) < col(mat)] < 10E-2]<-10E-2 - diag(mat)<-NA - - colnames(mat) <- rownames(mat)<- colnames(input.seq$data.name$geno)[input.seq$seq.num] - - if (mrk.axis == "numbers") - colnames(mat) <- rownames(mat)<- input.seq$seq.num - - # Be compatible with older versions - # if(all(is.na(input.seq$data.name$segr.type.num))){ - # if(inherits(input.seq$data.name, "backcross")){ - # segr.type.num <- rep(8, length(input.seq$data.name$segr.type)) - # } else { - # segr.type.num <- rep(9, length(input.seq$data.name$segr.type)) - # } - # } else { - # segr.type.num <- input.seq$data.name$segr.type.num - # } - - ##Write NAs in two-point recombination fractions between markers of type D1 and D2 - if(inherits(input.seq$data.name, c("outcross", "f2"))){ - types <- input.seq$data.name$segr.type.num[input.seq$seq.num] - for(i in 1:length(types)) - for(j in 1:(length(types)-1)) - if((types[i] == 7 & types[j] == 6) | (types[i] == 6 & types[j] == 7)){ - mat[i,j] <- mat[j,i] <- NA - } - } - ## Marker types - types <- input.seq$data.name$segr.type[input.seq$seq.num] - - ##Write multipoint estimates - if(length(input.seq$seq.rf) > 1){ - for (i in 1:(n.mrk-1)){ - mat[i+1,i] <- input.seq$seq.rf[i] - } - } - missing<-100*apply(input.seq$data.name$geno[,input.seq$seq.num],2, function(x) sum(x==0))/input.seq$data.name$n.ind - - ## Building the data.frame to plot - mat.LOD <- mat.rf <- mat - mat.LOD[lower.tri(mat.LOD)] <- t(mat.LOD)[lower.tri(mat.LOD)] - mat.rf[upper.tri(mat.rf)] <- t(mat.rf)[upper.tri(mat.LOD)] - - if(inherits(input.seq$data.name, c("outcross", "f2"))){ - if(inter){ - colnames(LOD$CC) <- rownames(LOD$CC) <- colnames(mat.rf) - colnames(LOD$CR) <- rownames(LOD$CR) <- colnames(mat.rf) - colnames(LOD$RC) <- rownames(LOD$RC) <- colnames(mat.rf) - colnames(LOD$RR) <- rownames(LOD$RR) <- colnames(mat.rf) - - ## Merging all the matrices into one df - df.graph <- Reduce(function(x, y) merge(x, y, all=TRUE), - list(melt(round(mat.rf,2), value.name="rf"), - melt(round(mat.LOD,2), value.name="LOD"), - melt(round(LOD$CC,2), value.name="CC"), - melt(round(LOD$CR,2), value.name="CR"), - melt(round(LOD$RC,2), value.name="RC"), - melt(round(LOD$RR,2), value.name="RR"))) - - colnames(df.graph)[5:8] <- paste0("LOD.",c("CC","CR","RC","RR")) - } else { - df.graph <- Reduce(function(x, y) merge(x, y, all=TRUE), - list(melt(round(mat.rf,2), value.name="rf"), - melt(round(mat.LOD,2), value.name="LOD"))) - } - }else{ - df.graph <- merge(melt(round(mat.rf,2), value.name="rf"), - melt(round(mat.LOD,2), value.name="LOD")) - } - - colnames(df.graph)[c(1,2)] <- c("x", "y") - - if(mrk.axis=="numbers"){ - df.graph$x <- factor(df.graph$x, levels = as.character(input.seq$seq.num)) - df.graph$y <- factor(df.graph$y, levels = as.character(input.seq$seq.num)) - } - - missing <- paste0(round(missing,2),"%") - - mrk.type.x <- data.frame(x=colnames(mat.rf),x.type=types) - mrk.type.y <- data.frame(y=colnames(mat.rf),y.type=types) - missing.x <- data.frame(x=colnames(mat.rf),x.missing=missing) - missing.y <- data.frame(y=colnames(mat.rf),y.missing=missing) - - df.graph <- Reduce(function(x, y) merge(x, y, all=TRUE), - list(df.graph, - mrk.type.x, - mrk.type.y, - missing.x, - missing.y)) - - ## Within the df.graph dataframe we plot based on the arguments and data.type - ## Additional aesthetical (aes) arguments are to be passed to the mouse hover in the interactive plot. - ## ggplot() just depends on the 'x', 'y', and 'fill' aes arguments - - ## If outcross: - if(inherits(input.seq$data.name, c("outcross", "f2"))){ - if(graph.LOD!=TRUE){ - if(inter){ - p <- ggplot(aes(x, y, x.type = x.type, y.type = y.type, x.missing = x.missing, y.missing = y.missing, fill = rf, LOD.CC=LOD.CC, LOD.CR=LOD.CR, LOD.RC=LOD.RC, LOD.RR=LOD.RR), data=df.graph) + - geom_tile() + - scale_fill_gradientn(colours = rainbow(n.colors), na.value = "white") + - theme(axis.text.x=element_text(angle=90, hjust=1)) - } else { - p <- ggplot(aes(x, y, x.type = x.type, y.type = y.type, x.missing = x.missing, y.missing = y.missing, fill = rf), data=df.graph) + - geom_tile() + - scale_fill_gradientn(colours = rainbow(n.colors), na.value = "white") + - theme(axis.text.x=element_text(angle=90, hjust=1)) - } - }else{ - if(inter){ - p <- ggplot(aes(x, y, x.type = x.type, y.type = y.type, x.missing = x.missing, y.missing = y.missing, rf=rf, fill = LOD, LOD.CC=LOD.CC, LOD.CR=LOD.CR, LOD.RC=LOD.RC, LOD.RR=LOD.RR), data=df.graph) + - geom_tile() + - scale_fill_gradientn(colours = rev(rainbow(n.colors)), na.value = "white") + - theme(axis.text.x=element_text(angle=90, hjust=1)) - } else { - p <- ggplot(aes(x, y, x.type = x.type, y.type = y.type, x.missing = x.missing, y.missing = y.missing, rf=rf, fill = LOD), data=df.graph) + - geom_tile() + - scale_fill_gradientn(colours = rev(rainbow(n.colors)), na.value = "white") + - theme(axis.text.x=element_text(angle=90, hjust=1)) - } - } - - ## If inbred: - }else{ - if(graph.LOD!=TRUE){ - p <- ggplot(aes(x, y, x.missing = x.missing, y.missing = y.missing, fill=rf, LOD=LOD), data=df.graph) + - geom_tile() + - scale_fill_gradientn(colours = rainbow(n.colors), na.value = "white") + - theme(axis.text.x=element_text(angle=90, hjust=1)) - }else{ - p <- ggplot(aes(x, y, x.missing = x.missing, y.missing = y.missing, rf=rf, fill=LOD), data=df.graph) + - geom_tile() + - scale_fill_gradientn(colours = rev(rainbow(n.colors)), na.value = "white") + - theme(axis.text.x=element_text(angle=90, hjust=1)) - } - } - - ## Disable lab names: - if(is.null(lab.xy)){ - p <- p + labs(x = " ", y = " ") - } else { - if(length(lab.xy)!=2){ - warning("You should give a character vector with two components to axis labels") - }else{ - p <- p + labs(x = lab.xy[1], y = lab.xy[2]) - } - } - - ## Disable markers names: - if(mrk.axis=="none"){ - p <- p + theme(axis.text.x = element_blank(), axis.text.y = element_blank()) - } - - ## Write main - if(!is.null(main)){ - p <- p + ggtitle(main) - } - - ## Interactive - if(inter){ - if(is.null(html.file)){ - stop("For interactive mode you must define a name for the outputted html file in 'html.file' argument.") - }else{ - p <- ggplotly(p) - - if(display){ - saveWidget(p, file = html.file) - browseURL(html.file) - } else { - p - } - } - }else{ - p #it is a ggplot which can be expanded (+). - } -} +##################################################################################### +## ## +## Package: onemap ## +## ## +## File: rf_graph_table.R ## +## Contains: rf_graph_table ## +## ## +## Written by Marcelo Mollinari ## +## Upgraded to ggplot2/plotly by Rodrigo Amadeu and Cristiane Taniguti ## +## copyright (c) 2018, Marcelo Mollinari and Rodrigo Amadeu and Cristiane Taniguti ## +## ## +## First version: 2009/05/03 ## +## Last update: 2018/05/15 ## +## Description was modified by Augusto Garcia on 2015/07/25 ## +## Upgrade to ggplot2/plotly by Rodrigo Amadeu on 2018/02/15 ## +## License: GNU General Public License version 2 (June, 1991) or later ## +## ## +##################################################################################### + +globalVariables(c("x", "y", "x.type", "rf")) +globalVariables(c("y.type", "x.missing")) +globalVariables(c("y.missing", "LOD.CC")) +globalVariables(c("LOD.CR", "LOD.RC", "LOD.RR")) + +##' Plots pairwise recombination fractions and LOD Scores in a heatmap +##' +##' Plots a matrix of pairwise recombination fraction or +##' LOD Scores using a color scale. Any value of the +##' matrix can be easily accessed using an interactive plotly-html interface, +##' helping users to check for possible problems. +##' +##' The color scale varies from red (small distances or big LODs) to purple. +##' When hover on a cell, a dialog box is displayed with some information +##' about corresponding markers for that cell (line (y) \eqn{\times} column (x)). They are: +##' \eqn{i}) the name of the markers; \eqn{ii}) the number of +##' the markers on the data set; \eqn{iii}) the segregation types; \eqn{iv}) +##' the recombination fraction between the markers and \eqn{v}) the LOD-Score +##' for each possible linkage phase calculated via two-point analysis. For +##' neighbor markers, the multipoint recombination fraction is printed; +##' otherwise, the two-point recombination fraction is printed. For markers of +##' type \code{D1} and \code{D2}, it is impossible to calculate recombination +##' fraction via two-point analysis and, therefore, the corresponding cell will +##' be empty (white color). For cells on the diagonal of the matrix, the name, the number and +##' the type of the marker are printed, as well as the percentage of missing +##' data for that marker. +##' +##' @import ggplot2 +##' @importFrom reshape2 melt +##' @importFrom grDevices rainbow +##' @importFrom plotly ggplotly +##' @importFrom htmlwidgets saveWidget +##' @importFrom utils browseURL +##' +##' @param input.seq an object of class \code{sequence} with a predefined +##' order. +##' @param graph.LOD logical. If \code{TRUE}, displays the LOD heatmap, otherwise, +##' displays the recombination fraction heatmap. +##' @param main character. The title of the plot. +##' @param inter logical. If \code{TRUE}, an interactive HTML graphic is plotted. +##' Otherwise, a default graphic device is used. +##' @param html.file character naming the html file with interative graphic. +##' @param mrk.axis character, "names" to display marker names in the axis, "numbers" to display +##' marker numbers and "none" to display axis free of labels. +##' @param lab.xy character vector with length 2, first component is the label of x axis and second of the y axis. +##' @param n.colors integer. Number of colors in the pallete. +##' @param display logical. If inter \code{TRUE} and display \code{TRUE} interactive graphic is plotted in browser automatically when run the function +##' +##' @return a ggplot graphic +##' +##' @author Rodrigo Amadeu, \email{rramadeu@@gmail.com} +##' @keywords utilities +##' @examples +##' +##'\donttest{ +##' ##outcross example +##' data(onemap_example_out) +##' twopt <- rf_2pts(onemap_example_out) +##' all_mark <- make_seq(twopt,"all") +##' groups <- group(all_mark) +##' LG1 <- make_seq(groups,1) +##' LG1.rcd <- rcd(LG1) +##' rf_graph_table(LG1.rcd, inter=FALSE) +##' +##' +##' ##F2 example +##' data(onemap_example_f2) +##' twopt <- rf_2pts(onemap_example_f2) +##' all_mark <- make_seq(twopt,"all") +##' groups <- group(all_mark) +##' +##' ##"pre-allocate" an empty list of length groups$n.groups (3, in this case) +##' maps.list<-vector("list", groups$n.groups) +##' +##' for(i in 1:groups$n.groups){ +##' ##create linkage group i +##' LG.cur <- make_seq(groups,i) +##' ##ordering +##' map.cur<-order_seq(LG.cur, subset.search = "sample") +##' ##assign the map of the i-th group to the maps.list +##' maps.list[[i]]<-make_seq(map.cur, "force") +##' } +##' } +##'@export +rf_graph_table <- function(input.seq, + graph.LOD=FALSE, + main=NULL, + inter=FALSE, + html.file = NULL, + mrk.axis="numbers", + lab.xy=NULL, + n.colors=4, + display=TRUE){ + + ## checking for correct objects + if(!any(inherits(input.seq,"sequence"))) + stop(deparse(substitute(input.seq))," is not an object of class 'sequence'") + if(!(mrk.axis=="names" | mrk.axis=="numbers" | mrk.axis=="none")) + stop("This mrk.axis argument is not defined, choose 'names', 'numbers' or 'none'") + + ## extracting data + if(inherits(input.seq$data.name, c("outcross", "f2"))) + { + ## making a list with necessary information + n.mrk <- length(input.seq$seq.num) + if(inter){ + LOD <- lapply(input.seq$twopt$analysis, + function(x, w){ + m <- matrix(0,nrow = length(w), ncol = length(w)) + k <- matrix(c(rep(w[1:(length(w))], each = length(w)), + rep(w[1:(length(w))], length(w))), ncol = 2) + k <- k[-which(k[,1] == k[,2]),] + k <- t(apply(k, 1, sort)) + k <- k[-which(duplicated(k)),] + LOD.temp<- x[k[,c(1,2)]] + m[lower.tri((m))] <- LOD.temp + m[upper.tri(m)] <- t(m)[upper.tri(m)] + return(m) + }, input.seq$seq.num + ) + } + mat<-t(get_mat_rf_out(input.seq, LOD=TRUE, max.rf = 0.501, min.LOD = -0.1)) + } else { + ## making a list with necessary information + n.mrk <- length(input.seq$seq.num) + if(inter){ + LOD<-matrix(0, length(input.seq$seq.num), length(input.seq$seq.num)) + k <- matrix(c(rep(input.seq$seq.num[1:(length(input.seq$seq.num))], each = length(input.seq$seq.num)), + rep(input.seq$seq.num[1:(length(input.seq$seq.num))], length(input.seq$seq.num))), ncol = 2) + k <- k[-which(k[,1] == k[,2]),] + k <- t(apply(k, 1, sort)) + k <- k[-which(duplicated(k)),] + LOD.temp<- input.seq$twopt$analysis[k[,c(1,2)]] + LOD[lower.tri((LOD))] <- LOD.temp + LOD[upper.tri(LOD)] <- t(LOD)[upper.tri(LOD)] + } + mat<-t(get_mat_rf_in(input.seq, LOD=TRUE, max.rf = 0.501, min.LOD = -0.1)) + } + + ##Scaling the LODs to print them properly + ## range.LOD<-range(as.dist(t(mat)), na.rm=TRUE) + ## range.rf<-range(as.dist(mat), na.rm=TRUE) + mat[row(mat) > col(mat) & mat > 0.5] <- 0.5 ## if there are recombinations greater than 0.5 (for numerical convergence problems), assuming 0.5 + mat[row(mat) < col(mat)][mat[row(mat) < col(mat)] < 10E-2]<-10E-2 + diag(mat)<-NA + + colnames(mat) <- rownames(mat)<- colnames(input.seq$data.name$geno)[input.seq$seq.num] + + if (mrk.axis == "numbers") + colnames(mat) <- rownames(mat)<- input.seq$seq.num + + # Be compatible with older versions + # if(all(is.na(input.seq$data.name$segr.type.num))){ + # if(inherits(input.seq$data.name, "backcross")){ + # segr.type.num <- rep(8, length(input.seq$data.name$segr.type)) + # } else { + # segr.type.num <- rep(9, length(input.seq$data.name$segr.type)) + # } + # } else { + # segr.type.num <- input.seq$data.name$segr.type.num + # } + + ##Write NAs in two-point recombination fractions between markers of type D1 and D2 + if(inherits(input.seq$data.name, c("outcross"))){ + types <- input.seq$data.name$segr.type.num[input.seq$seq.num] + for(i in 1:length(types)) + for(j in 1:(length(types)-1)) + if((types[i] == 7 & types[j] == 6) | (types[i] == 6 & types[j] == 7)){ + mat[i,j] <- mat[j,i] <- NA + } + } + ## Marker types + types <- input.seq$data.name$segr.type[input.seq$seq.num] + + ##Write multipoint estimates + if(length(input.seq$seq.rf) > 1){ + for (i in 1:(n.mrk-1)){ + mat[i+1,i] <- input.seq$seq.rf[i] + } + } + missing<-100*apply(input.seq$data.name$geno[,input.seq$seq.num],2, function(x) sum(x==0))/input.seq$data.name$n.ind + + ## Building the data.frame to plot + mat.LOD <- mat.rf <- mat + mat.LOD[lower.tri(mat.LOD)] <- t(mat.LOD)[lower.tri(mat.LOD)] + mat.rf[upper.tri(mat.rf)] <- t(mat.rf)[upper.tri(mat.LOD)] + + if(inherits(input.seq$data.name, c("outcross", "f2"))){ + if(inter){ + colnames(LOD$CC) <- rownames(LOD$CC) <- colnames(mat.rf) + colnames(LOD$CR) <- rownames(LOD$CR) <- colnames(mat.rf) + colnames(LOD$RC) <- rownames(LOD$RC) <- colnames(mat.rf) + colnames(LOD$RR) <- rownames(LOD$RR) <- colnames(mat.rf) + + ## Merging all the matrices into one df + df.graph <- Reduce(function(x, y) merge(x, y, all=TRUE), + list(melt(round(mat.rf,2), value.name="rf"), + melt(round(mat.LOD,2), value.name="LOD"), + melt(round(LOD$CC,2), value.name="CC"), + melt(round(LOD$CR,2), value.name="CR"), + melt(round(LOD$RC,2), value.name="RC"), + melt(round(LOD$RR,2), value.name="RR"))) + + colnames(df.graph)[5:8] <- paste0("LOD.",c("CC","CR","RC","RR")) + } else { + df.graph <- Reduce(function(x, y) merge(x, y, all=TRUE), + list(melt(round(mat.rf,2), value.name="rf"), + melt(round(mat.LOD,2), value.name="LOD"))) + } + }else{ + df.graph <- merge(melt(round(mat.rf,2), value.name="rf"), + melt(round(mat.LOD,2), value.name="LOD")) + } + + colnames(df.graph)[c(1,2)] <- c("x", "y") + + if(mrk.axis=="numbers"){ + df.graph$x <- factor(df.graph$x, levels = as.character(input.seq$seq.num)) + df.graph$y <- factor(df.graph$y, levels = as.character(input.seq$seq.num)) + } + + missing <- paste0(round(missing,2),"%") + + mrk.type.x <- data.frame(x=colnames(mat.rf),x.type=types) + mrk.type.y <- data.frame(y=colnames(mat.rf),y.type=types) + missing.x <- data.frame(x=colnames(mat.rf),x.missing=missing) + missing.y <- data.frame(y=colnames(mat.rf),y.missing=missing) + + df.graph <- Reduce(function(x, y) merge(x, y, all=TRUE), + list(df.graph, + mrk.type.x, + mrk.type.y, + missing.x, + missing.y)) + + ## Within the df.graph dataframe we plot based on the arguments and data.type + ## Additional aesthetical (aes) arguments are to be passed to the mouse hover in the interactive plot. + ## ggplot() just depends on the 'x', 'y', and 'fill' aes arguments + + ## If outcross: + if(inherits(input.seq$data.name, c("outcross", "f2"))){ + if(graph.LOD!=TRUE){ + if(inter){ + p <- ggplot(aes(x, y, x.type = x.type, y.type = y.type, x.missing = x.missing, y.missing = y.missing, fill = rf, LOD.CC=LOD.CC, LOD.CR=LOD.CR, LOD.RC=LOD.RC, LOD.RR=LOD.RR), data=df.graph) + + geom_tile() + + scale_fill_gradientn(colours = rainbow(n.colors), na.value = "white") + + theme(axis.text.x=element_text(angle=90, hjust=1)) + } else { + p <- ggplot(aes(x, y, x.type = x.type, y.type = y.type, x.missing = x.missing, y.missing = y.missing, fill = rf), data=df.graph) + + geom_tile() + + scale_fill_gradientn(colours = rainbow(n.colors), na.value = "white") + + theme(axis.text.x=element_text(angle=90, hjust=1)) + } + }else{ + if(inter){ + p <- ggplot(aes(x, y, x.type = x.type, y.type = y.type, x.missing = x.missing, y.missing = y.missing, rf=rf, fill = LOD, LOD.CC=LOD.CC, LOD.CR=LOD.CR, LOD.RC=LOD.RC, LOD.RR=LOD.RR), data=df.graph) + + geom_tile() + + scale_fill_gradientn(colours = rev(rainbow(n.colors)), na.value = "white") + + theme(axis.text.x=element_text(angle=90, hjust=1)) + } else { + p <- ggplot(aes(x, y, x.type = x.type, y.type = y.type, x.missing = x.missing, y.missing = y.missing, rf=rf, fill = LOD), data=df.graph) + + geom_tile() + + scale_fill_gradientn(colours = rev(rainbow(n.colors)), na.value = "white") + + theme(axis.text.x=element_text(angle=90, hjust=1)) + } + } + + ## If inbred: + }else{ + if(graph.LOD!=TRUE){ + p <- ggplot(aes(x, y, x.missing = x.missing, y.missing = y.missing, fill=rf, LOD=LOD), data=df.graph) + + geom_tile() + + scale_fill_gradientn(colours = rainbow(n.colors), na.value = "white") + + theme(axis.text.x=element_text(angle=90, hjust=1)) + }else{ + p <- ggplot(aes(x, y, x.missing = x.missing, y.missing = y.missing, rf=rf, fill=LOD), data=df.graph) + + geom_tile() + + scale_fill_gradientn(colours = rev(rainbow(n.colors)), na.value = "white") + + theme(axis.text.x=element_text(angle=90, hjust=1)) + } + } + + ## Disable lab names: + if(is.null(lab.xy)){ + p <- p + labs(x = " ", y = " ") + } else { + if(length(lab.xy)!=2){ + warning("You should give a character vector with two components to axis labels") + }else{ + p <- p + labs(x = lab.xy[1], y = lab.xy[2]) + } + } + + ## Disable markers names: + if(mrk.axis=="none"){ + p <- p + theme(axis.text.x = element_blank(), axis.text.y = element_blank()) + } + + ## Write main + if(!is.null(main)){ + p <- p + ggtitle(main) + } + + ## Interactive + if(inter){ + if(is.null(html.file)){ + stop("For interactive mode you must define a name for the outputted html file in 'html.file' argument.") + }else{ + p <- ggplotly(p) + + if(display){ + saveWidget(p, file = html.file) + browseURL(html.file) + } else { + p + } + } + }else{ + p #it is a ggplot which can be expanded (+). + } +} From 1fb5e89f45a542b555f78f9b4bf7178580f8bf0d Mon Sep 17 00:00:00 2001 From: Cristianetaniguti Date: Fri, 25 Oct 2024 15:08:51 -0400 Subject: [PATCH 36/36] change dominant codification --- R/codif_data.R | 8 ++++---- R/read_mapmaker.R | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/R/codif_data.R b/R/codif_data.R index 7393744..725d643 100644 --- a/R/codif_data.R +++ b/R/codif_data.R @@ -145,13 +145,13 @@ codif_data <- function(geno.in, segr.type.in, segr.type.out[i] <- 4 }, D.B = { - geno.out[which(geno.in[,i]=="b"),i] <- 1 - geno.out[which(geno.in[,i]=="d"),i] <- 2 + geno.out[which(geno.in[,i]=="b"),i] <- 2 + geno.out[which(geno.in[,i]=="d"),i] <- 1 segr.type.out[i] <- 5 }, C.A = { - geno.out[which(geno.in[,i]=="a"),i] <- 1 - geno.out[which(geno.in[,i]=="c"),i] <- 2 + geno.out[which(geno.in[,i]=="a"),i] <- 2 + geno.out[which(geno.in[,i]=="c"),i] <- 1 segr.type.out[i] <- 5 } ) diff --git a/R/read_mapmaker.R b/R/read_mapmaker.R index a9e7ef0..76a536a 100644 --- a/R/read_mapmaker.R +++ b/R/read_mapmaker.R @@ -277,10 +277,10 @@ read_mapmaker<-function (file=NULL, dir=NULL, verbose=TRUE) segr.type.num[segr.type=="D.B"]<-5 segr.type.num[segr.type=="M.X"]<-0 # Adapting to change in f2 HMM == out HMM - geno[, segr.type=="C.A"][which(geno[, segr.type=="C.A"] == 1)] <- 1 - geno[, segr.type=="C.A"][which(geno[, segr.type=="C.A"] == 5)] <- 2 - geno[, segr.type=="D.B"][which(geno[, segr.type=="D.B"] == 4)] <- 2 - geno[, segr.type=="D.B"][which(geno[, segr.type=="D.B"] == 3)] <- 1 + geno[, segr.type=="C.A"][which(geno[, segr.type=="C.A"] == 1)] <- 2 + geno[, segr.type=="C.A"][which(geno[, segr.type=="C.A"] == 5)] <- 1 + geno[, segr.type=="D.B"][which(geno[, segr.type=="D.B"] == 4)] <- 1 + geno[, segr.type=="D.B"][which(geno[, segr.type=="D.B"] == 3)] <- 2 geno[is.na(geno)]<-0 } else if(type=="backcross"){