######################################################################
# write.cross.qtab.R
#
# copyright (c) 2012-2019, Karl W Broman and Danny Arends
# last modified Dec, 2019
# first written Jul, 2012
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License,
# version 3, as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but without any warranty; without even the implied warranty of
# merchantability or fitness for a particular purpose. See the GNU
# General Public License, version 3, for more details.
#
# A copy of the GNU General Public License, version 3, is available
# at http://www.r-project.org/Licenses/GPL-3
#
# Part of the R/qtl package
# Contains: write.cross.qtab
# rqtl.to.qtab.* where * = symbols, location, genotypes, phenotypes, founder
# get.qtlHD.ID, get.indID.for.qtab, getgenonames.for.qtab
# get.qtab.geno.symbols, get.phenotype.type
#
######################################################################
# write cross in a set of qtab-format files
write.cross.qtab <-
function(cross, filestem="data", descr, verbose=TRUE)
{
if(!inherits(cross, "cross"))
stop("Input should have class \"cross\".")
if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl")
# for now, omit X chromosome
chr_type <- sapply(cross$geno, chrtype)
if(any(chr_type == "X")) {
cross <- subset(cross, chr=names(chr_type)[chr_type != "X"])
warning("Omitting X chromosome.")
}
if(verbose) cat("Writing symbols\n")
rqtl.to.qtab.symbols(cross, paste(filestem,"_symbols.qtab",sep=""), descr=descr)
if(verbose) cat("Writing founder file\n")
rqtl.to.qtab.founder(cross, paste(filestem,"_founder.qtab",sep=""), descr=descr)
if(verbose) cat("Writing genetic map\n")
rqtl.to.qtab.location(cross, paste(filestem,"_location.qtab",sep=""), descr=descr)
if(verbose) cat("Writing genotypes\n")
rqtl.to.qtab.genotypes(cross, paste(filestem,"_genotypes.qtab",sep=""), descr=descr)
if(verbose) cat("Writing phenotypes\n")
rqtl.to.qtab.phenotypes(cross, paste(filestem,"_phenotypes.qtab",sep=""), descr=descr)
}
# version number for qtlHD
get.qtlHD.ID <-
function(){
VER <- "0.1"
ID <- paste("qtlHD-in-", VER, sep="")
ID
}
# individual IDs for qtab files
get.indID.for.qtab <-
function(cross)
{
id <- getid(cross)
if(is.null(id)) id <- 1:nind(cross)
paste("ID_", id, sep="")
}
# genotype codes for qtab files
getgenonames.for.qtab <-
function(cross)
{
gnames <- getgenonames(crosstype(cross), "A", "full", getsex(cross), attributes(cross))
if(crosstype(cross) == "f2") {
gnames <- c(gnames, paste(gnames[1], "or", gnames[2], sep=""), paste(gnames[2], "or", gnames[3], sep=""))
}
c("-", gnames)
}
# qtab genotypes symbols
get.qtab.geno.symbols <-
function(cross)
{
crtype <- crosstype(cross)
if(crtype == "bc") {
return(c("None", "0,0", "0,1"))
}
if(crtype == "riself" || crtype == "risib") {
return(c("None", "0,0", "1,1"))
}
if(crtype == "f2") {
return(c("None", "0,0", "0,1 1,0", "1,1", "0,0 0,1 1,0", "0,1 1,0 1,1"))
}
stop("cross type \"", crtype, "\" not yet supported for qtab.")
}
# write qtab symbols
rqtl.to.qtab.symbols <-
function(cross, filename="symbols.qtab",descr)
{
if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl")
cat(file=filename, "# --- ",get.qtlHD.ID()," Symbol ",descr, "\n",sep="");
cat(file=filename, "# --- Genotype Symbol begin\n", append=TRUE)
gnames <- getgenonames.for.qtab(cross)
symbols <- get.qtab.geno.symbols(cross)
for(i in seq(along=gnames)) {
cat(file=filename, gnames[i], " as ", symbols[i], "\n", sep="", append=TRUE)
}
cat(file=filename, "# --- Genotype Symbol end\n", append=TRUE)
}
# write qtab marker map
rqtl.to.qtab.location <-
function(cross, filename="locations.qtab", descr)
{
if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl")
cat(file=filename, "# --- ",get.qtlHD.ID()," Location ", descr, "\n", sep="")
cat(file=filename, "# --- Data Location begin\n", append=TRUE)
cat(file=filename, "#\tChr\tPos\n", append=TRUE)
map <- pull.map(cross, as.table=TRUE)
map <- cbind(rownames(map), map)
write.table(map, file=filename, append=TRUE, quote=FALSE, sep="\t", na="-", row.names=FALSE, col.names=FALSE)
cat(file=filename, "# --- Data Location end\n", append=TRUE)
}
rqtl.to.qtab.genotypes <-
function(cross, filename="genotypes.qtab", descr)
{
if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl")
cat(file=filename, "# --- ",get.qtlHD.ID()," Genotype ", descr, "\n", sep="")
cat(file=filename, "# --- Data Genotype begin\n", append=TRUE)
# pull out genotypes data; convert to strings
genotypes <- pull.geno(cross)
genotypes[is.na(genotypes)] <- 0
gnames <- getgenonames.for.qtab(cross)
gstr <- matrix(rep("", prod(dim(genotypes))), ncol=ncol(genotypes))
for(i in seq(along=gnames))
gstr[genotypes == (i-1)] <- gnames[i]
# add column with individual IDs
id <- get.indID.for.qtab(cross)
gstr <- cbind(id, gstr)
# marker names
cat(file=filename, "#", paste(colnames(genotypes), collapse="\t"), "\n", sep="", append=TRUE)
# genotypes
write.table(gstr, file=filename, append=TRUE, quote=FALSE, sep="\t", na="-", row.names=FALSE, col.names=FALSE)
cat(file=filename, "# --- Data Genotype end\n", append=TRUE)
}
rqtl.to.qtab.phenotypes <-
function(cross, filename="phenotypes.qtab", descr)
{
if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl")
cat(file=filename, "# --- ",get.qtlHD.ID()," Phenotype ", descr, "\n", sep="")
cat(file=filename, "# --- Type Phenotype begin\n", append=TRUE)
for(phename in colnames(cross$pheno)) {
cat(file=filename, phename, "\t", get.phenotype.type(cross,phename), "\n", sep="", append=TRUE)
}
cat(file=filename, "# --- Type Phenotype end", "\n", sep="", append=TRUE)
cat(file=filename, "# --- Data Phenotype begin", "\n", sep="", append=TRUE)
cat(file=filename, "#", paste(colnames(cross$pheno), collapse="\t"), "\n", sep="", append=TRUE)
# add column with individual IDs
id <- get.indID.for.qtab(cross)
phe <- cbind(id, cross$pheno)
write.table(phe, file=filename, append=TRUE, quote=FALSE, sep="\t", na="-", row.names=FALSE, col.names=FALSE)
cat(file=filename, "# --- Data Phenotype end", "\n", sep="", append=TRUE)
}
get.phenotype.type <-
function(cross, phenotype)
{
if(is.numeric(cross$pheno[,phenotype])) return("Float")
if(is.character(cross$pheno[,phenotype])) return("Char")
if(is.factor(cross$pheno[,phenotype])) return("Char")
return("Float")
}
rqtl.to.qtab.founder <-
function(cross, filename="founder.qtab", descr)
{
if(missing(descr)) descr <- paste(deparse(substitute(cross)), "from R/qtl")
cat(file=filename, "# --- ",get.qtlHD.ID()," Founder ", descr, "\n", sep="")
cat(file=filename, "# --- Set Founder begin\n", append=TRUE)
cat(file=filename, "Cross\t", toupper(crosstype(cross)), "\n", sep="", append=TRUE)
cat(file=filename, "# --- Set Founder end\n", append=TRUE)
}
# end of write.cross.qtab.R
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.