Nothing
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass Alphabet
#
# @title "The Alphabet class"
#
# \description{
#
# Class representing an alphabet (a set of symbols).
# @classhierarchy
#
# }
#
# @synopsis
#
# \arguments{
# \item{symbols}{A character vector containing the symbols for the alphabet. All elements must have the
# same length and no duplicates are allowed. No element of the vector may contain the dash symbol, which is reserved for gaps.}
# \item{type}{An identifier for the Alphabet object.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create an alphabet object
# a<-Alphabet(type="Binary",symbols=c("0","1"));
# # print summary
# summary(a);
# # change the identifier
# a$type<-"Nucleotide";
# # change the symbol set
# a$symbols<-c("A","T","G","C");
# # print summary again
# summary(a);
# # clone the alphabet object
# b<-clone(a);
# # test the equality of the symbol sets
# a == b;
# }
#
# @author
#
#
# \seealso{
# Site Process Event BinaryAlphabet NucleotideAlphabet AminoAcidAlphabet
# }
#
#*/###########################################################################
setConstructorS3(
"Alphabet",
function(
symbols=NA,
type="Generic",
...
){
symbol_length<-NA;
if(!missing(symbols)){
symbols<-as.character(symbols);
symbol_length<-.checkSymbolLengths(symbols);
if(!exists(x="PSIM_FAST")){
.checkSymbolDuplicates(symbols);
}
}
size<-NA;
if(!is.na(symbol_length)){
size<-length(symbols);
}
extend(PSRoot(), "Alphabet",
.symbols=symbols,
.symbolLength=symbol_length,
.size=size,
.type=type,
.write.protected=FALSE,
.is.alphabet=TRUE
);
},
###
enforceRCC=TRUE
);
##
## Method: .checkSymbolLengths
##
setMethodS3(
".checkSymbolLengths",
class="character",
function(
this,
...
){
if(length(this) == 0 ){return(0)}
symbol_lengths<-stringLengthVector(this);
if(length(unique(symbol_lengths)) != 1) {
throw("The symbols must have the same length!");
} else {
symbol_lengths[[1]];
}
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkSymbolDuplicates
##
setMethodS3(
".checkSymbolDuplicates",
class="character",
function(
this,
...
){
# Check for the gap character "-", and die if present:
if(length(grep("^-+$",this)) != 0){
throw("The symbol sets cannot contain the character \"-\" as that is reserved as a gap symbol!\n");
}
if(length(this) != length(unique(this))){
throw("The alphabet must not contain duplicated symbols!");
} else {
return(invisible(TRUE));
}
},
###
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkConsistency
##
setMethodS3(
".checkConsistency",
class="character",
function(
this,
...
){
.checkSymbolLengths(this);
.checkSymbolDuplicates(this);
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns an invisible TRUE if no inconsistencies found, throws an error otherwise.
# }
#
# \examples{
# # create an alphabet object
# a<-Alphabet(symbols=c(0,1));
# # check consistency
# print(checkConsistency(a));
# # mess up with the internals
# a$.symbols[1]<-"BAD";
# # NOT run: cosistency check now will throw an error
# \dontrun{ print(checkConsistency(a)); }
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="Alphabet",
function(
this,
...
){
if(is.null(this$.symbols)) {
throw("Alphabet symbols is NULL!\n");
}
else if(is.null(this$.size)) {
throw("Alphabet size is NULL!\n");
}
else if(is.null(this$.symbolLength)) {
throw("Alphabet symbol length is NULL!\n");
}
else if(is.null(this$.type)) {
throw("Alphabet type is NULL!\n");
}
# Disable write protection for a while.
wp<-this$writeProtected;
if(wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this){
this$symbols<-this$symbols;
if( length(this$symbols) != this$size) {
throw("Alphabet object inconsistent! Length mismatch!\n");
}
}
tryCatch(may.fail(this), finally=this$writeProtected<-wp);
.checkConsistency(this$.symbols);
},
###
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: ==
##
###########################################################################/**
#
# @RdocMethod ==
# \alias{!=.Alphabet}
# @title "Check if two alaphabet objects have the same symbol set"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{e1}{An Alphabet object.}
# \item{e2}{An Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
# \examples{
#
# # create an alpahabet object
# a<-Alphabet(symbols=c(0,1));
# # clone object
# b<-clone(a)
# # compare the two objects
# print(a == b)
# # modify symbol set in b
# b$symbols<-c("AT","GC");
# print(a == b)
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"==",
class="Alphabet",
function(
e1,
e2,
...
){
# First check by reference:
if ( equals(e1,e2) ) {return(TRUE)}
# Check if both objects inherit from Alphabet:
if(!exists(x="PSIM_FAST")){
if (!length(intersect(intersect(class(e1),class(e2)),c("Alphabet")))){
throw("Alphabet object compared to something else!");
}
}
# Check ANY flag:
if(!is.null(e1$.any.flag) | !is.null(e2$.any.flag)) { return(TRUE) }
# then check by value:
setequal(e1$.symbols,e2$.symbols);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: !=
##
setMethodS3(
"!=",
class="Alphabet",
function(
e1,
e2,
...
){
!'=='(e1,e2);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSymbols
##
###########################################################################/**
#
# @RdocMethod getSymbols
#
# @title "Get the symbol set from an Alphabet object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector containing the symbol set of the Alphabet object.
# }
#
# \examples{
#
# # create a new alphabet object
# a<-Alphabet(symbols=c("AC","GT"));
# # get the symbols
# getSymbols(a)
# # get the symbols by using the virtual field
# a$symbols
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSymbols",
class="Alphabet",
function(
this,
...
){
as.character(this$.symbols);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setSymbols
##
###########################################################################/**
#
# @RdocMethod setSymbols
#
# @title "Specify a new symbol set for an Alphabet object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Alphabet object.}
# \item{set}{The vector containing the new symbols set, automatically converted
# into a character vector.}
# \item{...}{Not used.}
# }
#
# \value{
# The new symbol set as a character vector.
# }
#
# \examples{
#
# # create a new alphabet object
# a<-Alphabet()
# a
# # specify a new symbol set
# setSymbols(a,c(0,1))
# a
# # the same, but now use the virtual field
# a$symbols<-c("A","T","G","C")
# a
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setSymbols",
class="Alphabet",
function(
this,
set, # the new symbol set
...
){
if (is.null(set)) {
throw("Cannot set NULL as symbols!\n");
}
.checkWriteProtection(this);
set<-as.character(set);
if(!exists(x="PSIM_FAST")){
.checkSymbolDuplicates(set)
}
this$.symbolLength<-.checkSymbolLengths(set);
this$.size<-length(set);
this$.symbols<-set;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSymbolLength
##
###########################################################################/**
#
# @RdocMethod getSymbolLength
#
# @title "Get the length of the symbols in a given alphabet object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
#
# # create an alphabet object
# a<-Alphabet(symbols=c("AAA","AAC"));
# # get symbol length
# getSymbolLength(a);
# # get symbol length via virtual field
# a$symbolLength
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSymbolLength",
class="Alphabet",
function(
this,
...
){
this$.symbolLength;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setSymbolLength
##
###########################################################################/**
#
# @RdocMethod setSymbolLength
#
# @title "Forbidden action: setting the symbol length for an Alphabet object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Alphabet object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setSymbolLength",
class="Alphabet",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSize
##
###########################################################################/**
#
# @RdocMethod getSize
#
# @title "Get the number of symbols in an Alphabet object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# An integer vector of length one.
# }
#
# \examples{
#
# # create an alphabet object
# a<-Alphabet(symbols=c(0,1,2,3,4,5))
# a
# # get alphabet size
# getSize(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSize",
class="Alphabet",
function(
this,
...
){
this$.size;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getType
##
###########################################################################/**
#
# @RdocMethod getType
#
# @title "Get Alphabet obejct type"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
#
# # create alphabet object
# a<-Alphabet(symbols=c(0,1),type="Binary");
# # get alphabet type
# getType(a)
# a$type
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getType",
class="Alphabet",
function(
this,
...
){
this$.type;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setType
##
###########################################################################/**
#
# @RdocMethod setType
#
# @title "Set Alphabet object type"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Alphabet object.}
# \item{new_type}{A character vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new type (invisible).
# }
#
# \examples{
# # create an alphabet object
# a<-Alphabet(symbols=c(1,2,3))
# # set a new type
# setType(a,"MyAlphabet")
# a$type
# # set type via virtual field
# a$type<-"MorphChars"
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setType",
class="Alphabet",
function(
this,
new_type,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if (length(new_type) != 1) {throw("The new type must be a character vector of length 1!")}
if (new_type == "" ){ throw("Cannot set empty type!")}
}
this$.type<-new_type;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: hasSymbols
##
###########################################################################/**
#
# @RdocMethod hasSymbols
#
# @title "Check if an Alphabet object has a given set of symbols"
#
# \description{
# @get "title".
# Returns true if the class of the object is "AnyAlphabet".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Alphabet object.}
# \item{sym}{A character vector.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
# \examples{
#
# # create alphabet object
# a<-Alphabet(symbols=c("A","T","G","C"));
# # check if it has the symbols "A" and "G"
# hasSymbols(a,c("A","G"))
# # check if has the symbol "X"
# hasSymbols(a,"X")
# # any alphabet returns true for every symbol
# b<-AnyAlphabet();
# hasSymbols(b,"X")
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"hasSymbols",
class="Alphabet",
function(
this,
sym,
...
){
sym<-unique(as.character(sym));
if (length(intersect(this$.symbols,sym)) == length(sym)){
return(TRUE);
}
# Check ANY flag:
else if(!is.null(this$.any.flag)) { return(TRUE) }
else {
return(FALSE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getWriteProtected
##
###########################################################################/**
#
# @RdocMethod getWriteProtected
#
# @title "Check if the object is write protected"
#
# \description{
# @get "title".
# Write protected objects cannot be modified through get/set methods and virtual fields.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
#
# # create an object
# o<-Alphabet()
# # toggle write protection
# o$writeProtected<-TRUE
# # check if it's write protected
# getWriteProtected(o)
# # check write protection via virtual field
# o$writeProtected
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getWriteProtected",
class="Alphabet",
function(
this,
...
){
this$.write.protected;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setWriteProtected
##
###########################################################################/**
#
# @RdocMethod setWriteProtected
#
# @title "Set the write protection field for an object"
#
# \description{
# @get "title".
# Write protected objects cannot be modified through get/set methods and virtual fields.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{A logical vector of size one.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE or FALSE.
# }
#
# \examples{
#
# # create an object
# o<-Alphabet()
# # toggle write protection
# setWriteProtected(o,TRUE)
# # check write protection
# o$writeProtected
# # set write protection via virtual field
# o$writeProtected<-FALSE
# o$writeProtected
#
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setWriteProtected",
class="Alphabet",
function(
this,
value,
...
){
if(!is.logical(value)) {throw("The new value must be logical!\n")}
else {
this$.write.protected<-value;
}
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkWriteProtection
##
setMethodS3(
".checkWriteProtection",
class="Alphabet",
function(
this,
...
){
if(exists(x="PSIM_FAST")){ return(FALSE) }
if(this$writeProtected) {throw("Cannot set value because the object is write protected!\n")}
else {return(invisible(FALSE))}
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setSize
##
###########################################################################/**
#
# @RdocMethod setSize
#
# @title "Forbidden action: setting the symbol set size of an Alphabet object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Alphabet object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setSize",
class="Alphabet",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: as.character
##
###########################################################################/**
#
# @RdocMethod as.character
#
# @title "Get the character representation of an Alphabet object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{An Alphabet object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns the character vector containing the symbol set.
# }
#
# \examples{
#
# # create alphabet object
# a<-Alphabet(symbols=c("A","T","G","C","N"))
# # get charcter representation
# as.character(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"as.character",
class="Alphabet",
function(
x,
...
){
x$.symbols;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.Alphabet
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-NucleotideAlphabet()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="Alphabet",
function(
object,
...
){
this<-object;
this$.summary$Type<-this$type;
this$.summary$Size<-this$size;
this$.summary$Symbols<-paste(this$symbols,collapse=' ');
this$.summary$"Symbol length"<-this$symbolLength;
if(getWriteProtected(this)){
this$.summary$"Write protected"<-TRUE;
}
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: is.Alphabet
##
###########################################################################/**
#
# @RdocDefault is.Alphabet
#
# @title "Check if an object is an instance of the Alphabet class"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
# \examples{
#
# # create an alphabet object
# a<-Alphabet()
# # create a PSRoot object
# o<-PSRoot()
# # check if they are alphabet objects
# is.Alphabet(a)
# is.Alphabet(o)
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"is.Alphabet",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.alphabet)){return(TRUE)}
if ( inherits(this, "Alphabet")) {
this$.is.alphabet<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: isEmpty
##
###########################################################################/**
#
# @RdocMethod isEmpty
#
# @title "Check if the symbol set is empty"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
# \examples{
#
# # create an empty alphabet
# a<-Alphabet();
# # check whether it is empty
# isEmpty(a)
# # specify a new symbol set
# a$symbols<-c(0,1)
# isEmpty(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"isEmpty",
class="Alphabet",
function(
this,
...
){
if(is.na(this$.size) | this$.size == 0 ){
return(TRUE);
}
else {
return(FALSE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
## cpREV
##
##########################################################################/**
#
# @RdocClass cpREV
#
# @title "The cpREV empirical amino acid substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Adachi, J., P. J. Waddell, W. Martin, and M. Hasegawa (2000) Plastid
# genome phylogeny and a model of amino acid substitution for proteins
# encoded by chloroplast DNA - Journal of Molecular Evolution 50:348--358
# DOI: 10.1007/s002399910038 \url{http://bit.ly/bnBVLm}
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-cpREV()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-AminoAcidSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# AminoAcidSubst GeneralSubstitution UNREST
# }
#
#*/###########################################################################
setConstructorS3(
"cpREV",
function(
equ.dist=NA,
...
){
this<-AminoAcidSubst$newAAMatrix(
name="cpREV",
paml.file="cpREV.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## PAM
##
##########################################################################/**
#
# @RdocClass PAM
#
# @title "The PAM empirical amino acid substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Dayhoff, M. O.; Schwartz, R. M.; Orcutt, B. C. (1978). "A model of evolutionary change in proteins" -
# Atlas of Protein Sequence and Structure 5 (3):345-352
#
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-PAM()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-AminoAcidSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# AminoAcidSubst GeneralSubstitution UNREST
# }
#
#*/###########################################################################
setConstructorS3(
"PAM",
function(
equ.dist=NA,
...
){
this<-AminoAcidSubst$newAAMatrix(
name="PAM",
paml.file="dayhoff.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## PAM-dcmut
##
##########################################################################/**
#
# @RdocClass PAM.dcmut
#
# @title "The PAM.dcmut empirical amino acid substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Kosiol, C, and Goldman, N (2005) Different versions of the Dayhoff rate matrix -
# Molecular Biology and Evolution 22:193-199 \url{http://dx.doi.org/10.1093/molbev/msi005}
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-PAM.dcmut()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-AminoAcidSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# AminoAcidSubst GeneralSubstitution UNREST
# }
#
#*/###########################################################################
setConstructorS3(
"PAM.dcmut",
function(
equ.dist=NA,
...
){
this<-AminoAcidSubst$newAAMatrix(
name="PAM.dcmut",
paml.file="dayhoff-dcmut.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## JTT
##
##########################################################################/**
#
# @RdocClass JTT
#
# @title "The JTT empirical amino acid substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Jones, D. T., W. R. Taylor, and J. M. Thornton (1992) The rapid generation of mutation data matrices
# from protein sequences. CABIOS 8:275-282 \url{http://dx.doi.org/10.1093/bioinformatics/8.3.275}
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-JTT()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-AminoAcidSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# AminoAcidSubst GeneralSubstitution UNREST
# }
#
#*/###########################################################################
setConstructorS3(
"JTT",
function(
equ.dist=NA,
...
){
this<-AminoAcidSubst$newAAMatrix(
name="JTT",
paml.file="jones.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## JTT.dcmut
##
##########################################################################/**
#
# @RdocClass JTT.dcmut
#
# @title "The JTT.dcmut empirical amino acid substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Kosiol, C, and Goldman, N (2005) Different versions of the Dayhoff rate matrix -
# Molecular Biology and Evolution 22:193-199 \url{http://dx.doi.org/10.1093/molbev/msi005}
#
# Jones, D. T., W. R. Taylor, and J. M. Thornton (1992) The rapid generation of mutation data matrices
# from protein sequences. CABIOS 8:275-282 \url{http://dx.doi.org/10.1093/bioinformatics/8.3.275}
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-JTT.dcmut()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-AminoAcidSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first threee positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# AminoAcidSubst GeneralSubstitution UNREST
# }
#
#*/###########################################################################
setConstructorS3(
"JTT.dcmut",
function(
equ.dist=NA,
...
){
this<-AminoAcidSubst$newAAMatrix(
name="JTT.dcmut",
paml.file="jones-dcmut.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## LG
##
##########################################################################/**
#
# @RdocClass LG
#
# @title "The LG empirical amino acid substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Le, S. Q., and O. Gascuel (2008) An improved general amino acid replacement matrix -
# Mol. Biol. Evol. 25:1307-1320 \url{http://dx.doi.org/10.1093/molbev/msn067}
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-LG()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-AminoAcidSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# AminoAcidSubst GeneralSubstitution UNREST
# }
#
#*/###########################################################################
setConstructorS3(
"LG",
function(
equ.dist=NA,
...
){
this<-AminoAcidSubst$newAAMatrix(
name="LG",
paml.file="lg.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## mtArt
##
##########################################################################/**
#
# @RdocClass mtArt
#
# @title "The mtArt empirical amino acid substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Abascal, F., D. Posada, and R. Zardoya (2007) MtArt: A new Model of
# amino acid replacement for Arthropoda - Mol. Biol. Evol. 24:1-5 \url{http://dx.doi.org/10.1093/molbev/msl136}
#
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-mtArt()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-AminoAcidSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# AminoAcidSubst GeneralSubstitution UNREST
# }
#
#*/###########################################################################
setConstructorS3(
"mtArt",
function(
equ.dist=NA,
...
){
this<-AminoAcidSubst$newAAMatrix(
name="mtArt",
paml.file="mtArt.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## mtMam
##
##########################################################################/**
#
# @RdocClass mtMam
#
# @title "The mtMam empirical amino acid substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Yang, Z., R. Nielsen, and M. Hasegawa (1998) Models of amino acid
# substitution and applications to Mitochondrial protein evolution,
# Molecular Biology and Evolution 15:1600-1611 \url{http://bit.ly/by4NMb}
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-mtMam()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-AminoAcidSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# AminoAcidSubst GeneralSubstitution UNREST
# }
#
#*/###########################################################################
setConstructorS3(
"mtMam",
function(
equ.dist=NA,
...
){
this<-AminoAcidSubst$newAAMatrix(
name="mtMam",
paml.file="mtmam.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## mtREV24
##
##########################################################################/**
#
# @RdocClass mtREV24
#
# @title "The mtREV24 empirical amino acid substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Adachi, J. and Hasegawa, M. (1996) MOLPHY version 2.3: programs for
# molecular phylogenetics based on maximum likelihood. Computer Science
# Monographs of Institute of Statistical Mathematics 28:1-150
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-mtREV24()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-AminoAcidSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# AminoAcidSubst GeneralSubstitution UNREST
# }
#
#*/###########################################################################
setConstructorS3(
"mtREV24",
function(
equ.dist=NA,
...
){
this<-AminoAcidSubst$newAAMatrix(
name="mtREV24",
paml.file="mtREV24.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## MtZoa
##
##########################################################################/**
#
# @RdocClass MtZoa
#
# @title "The MtZoa empirical amino acid substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Rota-Stabelli, O., Z. Yang, and M. Telford. (2009) MtZoa: a general mitochondrial amino acid
# substitutions model for animal evolutionary studies. Mol. Phyl. Evol 52(1):268-72 \url{http://bit.ly/2bMbGAl}
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-MtZoa()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-AminoAcidSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# AminoAcidSubst GeneralSubstitution UNREST
# }
#
#*/###########################################################################
setConstructorS3(
"MtZoa",
function(
equ.dist=NA,
...
){
this<-AminoAcidSubst$newAAMatrix(
name="MtZoa",
paml.file="MtZoa.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## WAG
##
##########################################################################/**
#
# @RdocClass WAG
#
# @title "The WAG empirical amino acid substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Whelan, S. and N. Goldman (2001) A general empirical model of
# protein evolution derived from multiple protein families using a maximum likelihood
# approach - Molecular Biology and Evolution 18:691-699 \url{http://bit.ly/dpTKAd}
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-WAG()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-AminoAcidSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# AminoAcidSubst GeneralSubstitution UNREST
# }
#
#*/###########################################################################
setConstructorS3(
"WAG",
function(
equ.dist=NA,
...
){
this<-AminoAcidSubst$newAAMatrix(
name="WAG",
paml.file="wag.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass AminoAcidSubst
#
# @title "The AminoAcidSubst class"
#
# \description{
# This is a class implementing a continuous-time Markov process acting on
# the state-space defined by the \code{AminoAcidAlphabet} class. The rate
# matrix of this model is completely unrestricted.
#
# The rate matrix can be built from PAML files specified by the \code{paml.file} argument.
# Alternatively the rates can be specified as a list through the \code{rate.list} parameter.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{paml.file}{The name of the PAML file used to construct the rate matrix.}
# \item{rate.list}{A list of unscaled substitution rates (see \code{setRateList.GeneralSubstitution}).}
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create an object
# p<-AminoAcidSubst()
# # build rate matrix from paml file
# # buildFromPAML(p,"path_to_paml_file") # do not run this
# # set a rate
# setRate(p,"A->D",2)
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setConstructorS3(
"AminoAcidSubst",
function(
name="Anonymous",
paml.file=NA,
rate.list=NA,
equ.dist=NA,
...
) {
got.rate.list<-!missing(rate.list);
got.equ.dist<-!missing(equ.dist);
extend.with.s<-function(this){
this<-extend(this, "AminoAcidSubst",
.s.matrix=data.matrix(matrix(ncol=this$.alphabet$size,nrow=this$.alphabet$size)),
.paml.file=NA
);
rownames(this$.s.matrix)<-this$.alphabet$.symbols;
colnames(this$.s.matrix)<-this$.alphabet$.symbols;
# Setting diagonal elements to zero:
diag(this$.s.matrix)<-0;
return(this);
}
this<-NA;
if(missing(paml.file)){
# No PAML file given
# Got rate list and equlibrium distribution:
if(got.rate.list & got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=AminoAcidAlphabet(),
rate.list=rate.list,
equ.dist=equ.dist
);
this<-extend(this, "AminoAcidSubst");
}
# Got rate list
else if(got.rate.list & !got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=AminoAcidAlphabet(),
rate.list=rate.list
);
this<-extend.with.s(this);
}
# Got equlibrium distribution,
else if(!got.rate.list & got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=AminoAcidAlphabet(),
equ.dist=equ.dist
);
this<-extend(this, "AminoAcidSubst");
this<-extend.with.s(this);
}
# Got nothing:
else if(!got.rate.list & !got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=AminoAcidAlphabet()
);
this<-extend.with.s(this);
}
}
else {
# PAML file given:
if( got.rate.list){
warning("Building process from PAML file, the \"rate.list\" parameter is ignored!\n");
}
this<-GeneralSubstitution(
name=name,
alphabet=AminoAcidAlphabet()
);
this<-extend.with.s(this);
if(got.equ.dist){
setEquDist(this,equ.dist,force=TRUE);
}
buildFromPAML(this, paml.file);
}
# Force clearing id cache:
this$name<-this$name;
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="AminoAcidSubst",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if(!inherits(this$alphabet, "AminoAcidAlphabet")){
throw("This process must have as alphabet an AminoAcidAlphabet object!\n");
}
if(!any(is.na(this$.s.matrix))){
for(i in this$.alphabet$.symbols){
for(j in this$.alphabet$.symbols){
if(i != j){
expected<-this$.s.matrix[i, j] * this$.equ.dist[1,j];
actual<-this$.q.matrix$.orig.matrix[i,j];
if(!PSRoot$my.all.equal(expected, actual)){
throw("The rate matrix is not compatible with the exchangeability matrix and the equilibrium distribution!\n");
}
}
}
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: buildFromPAML
##
###########################################################################/**
#
# @RdocMethod buildFromPAML
#
# @title "Build rate matrix from PAML file"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An AminoAcidSubst object.}
# \item{paml.file}{Path to the PAML file.}
# \item{...}{Not used.}
# }
#
# \value{
# The AminoAcidSubst object (invisible).
# }
#
# \examples{
# # create an object
# p<-AminoAcidSubst()
# # build rate matrix from paml file
# # buildFromPAML(p,"path_to_paml_file") # do not run this
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"buildFromPAML",
class="AminoAcidSubst",
function(
this,
paml.file,
...
){
if(!missing(paml.file)){
data<-.readFromPAML(this, paml.file=paml.file);
this$.paml.file<-paml.file;
if(all(is.na(this$equDist))){
setEquDist(this, value=data[["pi"]], force=TRUE, silent=TRUE)
}
S<-data$S;
this$.s.matrix<-S;
for(i in this$.alphabet$.symbols){
for(j in this$.alphabet$.symbols){
if(i != j){
setRate(this$.q.matrix,from=i,to=j,value=(S[i,j] * this$.equ.dist[1, j]),scale=FALSE);
}
}
}
.callRateRescaling(this$.q.matrix,guess.equ=FALSE);
}
else{
throw("PAML data file not specified");
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .readFromPAML
##
setMethodS3(
".readFromPAML",
class="AminoAcidSubst",
function(
this,
paml.file,
...
){
if(missing(paml.file)){
throw("No PAML data file specified!\n");
}
else if(file.access(c(paml.file), mode=0) != c(0)){
throw("The specified PAML data file \"",paml.file,"\" does not exist!\n",sep="");
}
else if(file.access(c(paml.file), mode=4) != c(0)){
throw("The specified PAML data file \"",paml.file,"\" cannot be opened for reading because of insufficient permissions!\n",sep="");
}
else {
size<-this$alphabet$size;
symbols<-this$alphabet$symbols;
lines<-scan(file=paml.file,what="character",sep="\n",blank.lines.skip=FALSE,quiet=TRUE);
is.blank<-function(line){
if(length(grep(pattern="^\\s*$",x=line,perl=TRUE,value=FALSE)) > 0 ){
return(TRUE);
}
else if(length(grep(pattern="\\d",x=line,perl=TRUE,value=FALSE)) < 1){
# If the line has no decimal number than is considered blank!
return(TRUE);
}
return(FALSE);
}
# Skip blank lines:
count<-1;
while(is.blank(lines[[count]])){
count<-count+1;
}
skip<-count-1;
# Find the beggining of the equilibrium distribution:
count<-skip+size+1;
while(is.blank(lines[[count]])){
count<-count+1;
}
equ.skip<-count-1;
# How many lines has the equilibrium distribution?
count<-equ.skip;
while(!is.blank(lines[[count<-count+1]])){ }
equ.nlines<-count-equ.skip-1;
# We don't need the lines any more.
rm(lines);
# Reading the exchangeability matrix:
# Assuming here that the order of the
# amino acids is the same as in the AminoAcidAlphabet
# object.
numbers<-scan(file=paml.file,what=0.0,skip=skip,nlines=(size-1),quiet=TRUE);
if(length(numbers) != ((size^2-size)/2)){
throw("Error reading exchangeability matrix from PAML data file!\n");
}
s.matrix<-matrix(nrow=size,ncol=size);
diag(s.matrix)<-0;
colnames(s.matrix)<-symbols;
rownames(s.matrix)<-symbols;
counter<-1;
for(i in 1:size) {
for(j in 1:i){
if( i!= j){
s.matrix[i, j]<-numbers[counter];
s.matrix[j, i]<-numbers[counter];
counter<-counter + 1;
}
}
}
# Reading the equilibrium distribution:
equ.dist<-(scan(file=paml.file,what=0.0,skip=equ.skip, nlines=equ.nlines, quiet=TRUE));
if(length(equ.dist) != size){
throw("Error reading equlibrium distribution from PAML data file!\n");
}
equ.dist<-rbind(equ.dist);
colnames(equ.dist)<-symbols;
return(list(
"S"=s.matrix,
"pi"=equ.dist
));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setEquDist
##
setMethodS3(
"setEquDist",
class="AminoAcidSubst",
function(
this,
value,
force=FALSE,
silent=FALSE,
...
){
# Behave like GeneralSubstitution if the S matrix is empty.
if(any(is.na(this$.s.matrix))){
return(NextMethod());
}
.checkWriteProtection(this);
if(!is.Alphabet(this$alphabet)){
throw("Cannot set equilibrium distribution because the alphabet is undefined!");
}
if(missing(value)) {
throw("No new value provided!\n");}
else if(!is.numeric(value)) {
throw("The new value must be numeric!\n");
}
else if(length(value) != this$alphabet$size){
throw("The new value must be a vector of length ",this$alphabet$size,"!\n");
}
else if(!PSRoot$my.all.equal(sum(value), 1.0)) {
value<-(value/sum(value));
if (silent == FALSE){
warning("The provided probabilities were rescaled in order to sum to one!\n");
}
}
value<-rbind(value);
colnames(value)<-this$.alphabet$symbols;
this$.equ.dist<-value;
for(i in this$.alphabet$.symbols){
for(j in this$.alphabet$.symbols){
if(i != j){
setRate(this$.q.matrix,from=i,to=j,value=(this$.s.matrix[i,j] * value[1, j]),scale=FALSE);
}
}
}
.callRateRescaling(this$QMatrix,guess.equ=FALSE);
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-AminoAcidSubst()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="AminoAcidSubst",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
.addSummaryAlphabet(this);
if(is.na(this$.paml.file)){
this$.summary$"Unscaled rate matrix"<-paste( "\n\t",paste(capture.output(print(this$.q.matrix$matrix,digits=5)
),collapse="\n\t"),"\n",sep="");
}
else {
this$.summary$"PAML data file:"<-this$.paml.file;
this$.summary$"Unscaled rate matrix"<-"not shown";
}
this$.summary$"Equilibrium distribution"<-paste( "\n\t",paste(capture.output(print(this$.equ.dist)),collapse="\n\t"
),"\n",sep="");
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: newAAMatrix
##
###########################################################################/**
#
# @RdocMethod newAAMatrix
#
# @title "Undocumented method"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name}
# \item{paml.file}{PAML file.}
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \value{
# A process object inheriting from AminoAcidSubst.
# }
#
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"newAAMatrix",
class="AminoAcidSubst",
function(
name=NA,
paml.file=NA,
equ.dist=NA,
...
){
PAMLDIR<-"./PAMLdat";
RDATDIR<-"./RData";
# Use the package data directory if loaded:
if(length(intersect(search(),c("package:phylosim"))) == 1){
RDATDIR<-paste(path.package("phylosim"),"/data/",sep="");
PAMLDIR<-paste(path.package("phylosim"),"/extdata/",sep="");
}
rdname<-paste(RDATDIR,"/",name,".RData",sep="");
if( ( file.access(c(rdname), mode=0) == c(0) ) & (file.access(c(rdname), mode=4) == c(0))){
this<-clone(Object$load(rdname));
}
else {
file<-paste(PAMLDIR,"/",paml.file,sep="");
this<-AminoAcidSubst(paml.file=file);
this<-extend(this,name);
this$name<-this$name;
save(this, file=rdname);
}
if(!any(is.na(equ.dist))){
setEquDist(this,value=equ.dist,force=TRUE);
}
return(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass BinarySubst
#
# @title "The BinarySubst class"
#
# \description{
# This is a class implementing a continuous-time Markov process acting on
# the state space defined by the \code{BinaryAlphabet} class.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{rate.list}{A list of substitution rates (see \code{setRateList.GeneralSubstitution}).}
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # The following code demonstrates
# # the use of the BinarySubst process
# # during a simulation.
# p<-BinarySubst(rate=0.25,name="Binary",rate.list=list("0->1"=2,"1->0"=1))
# # create a sequence object, attach process p
# s<-BinarySequence(string="000000000000000000",processes=list(list(p)));
# # make the first five positions invariable
# setRateMultipliers(s,p,0,1:5)
# # get rate multipliers
# getRateMultipliers(s,p)
# # simulate
# sim<-PhyloSim(root.seq=s,phylo=rcoal(3))
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GeneralSubstitution GTR WAG
# }
#
#*/###########################################################################
setConstructorS3(
"BinarySubst",
function(
name="Anonymous",
rate.list=NA,
equ.dist=NA,
...
) {
got.rate.list<-!missing(rate.list);
got.equ.dist<-!missing(equ.dist);
this<-NA;
if(got.rate.list & got.equ.dist){
this<-GeneralSubstitution(name=name, rate.list=rate.list, equ.dist=equ.dist, alphabet=BinaryAlphabet());
}
else if(got.rate.list & !got.equ.dist){
this<-GeneralSubstitution(name=name, rate.list=rate.list, alphabet=BinaryAlphabet());
}
else if(!got.rate.list & got.equ.dist){
this<-GeneralSubstitution(name=name, equ.dist=equ.dist, alphabet=BinaryAlphabet());
}
else if(!got.rate.list & !got.equ.dist){
this<-GeneralSubstitution(name=name, alphabet=BinaryAlphabet());
}
else {
throw("You should never see this message!\n");
}
this<-extend(this, "BinarySubst");
this$name<-this$name;
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="BinarySubst",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
is.binary.alphabet<-inherits(this$alphabet, "BinaryAlphabet");
if(!is.binary.alphabet){
throw("The alphabet must be a BinaryAlphabet object!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# p<-BinarySubst(rate=0.25,name="Binary",rate.list=list("0->1"=2,"1->0"=1))
# # get a summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="BinarySubst",
function(
object,
...
){
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass BrownianInsertor
#
# @title "The BrownianInsertor class"
#
# \description{
# The \code{BrownianInsertor} class inherits from the \code{DiscreteInsertor}
# or \code{ContinuousInsertor} class depending on the \code{type} constructor argument
# ("discrete" or "continuous").
#
# This process generates the insert sequence based on the sites flanking the insertions as follows:
# \itemize{
# \item An insert length is sampled by calling the function stored in the \code{proposeBy} virtual field.
# \item A sequence object is constructed.
# \item The processes attached to both flanking sites are attached to the insert sequence. If there are no common processes, the processes from a randomly chosen site will be attached to the insert.
# \item The site-process specific parameters are sampled from Brownian paths with linear trends having the values from the flanking sites as endpoints.
# }
#
# The "noisiness" of the Brownian path can be controlled through the \code{scale} virtual field/constructor parameter.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{type}{Process type (see above).}
# \item{scale}{Brownian path scale parameter.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a BrownianInsertor process, discrete type
# p<-BrownianInsertor(
# type="discrete",
# scale=0.05,
# sizes=1:4,
# probs=c(3/6,1/6,1/6,1/6),
# rate=0.05
# )
# # get object summary
# summary(p)
# # plot insert length distribution
# plot(p)
# # create a nucleotide sequence, attach processes
# s<-NucleotideSequence(string="AAAAAAAAAAA",processes=list(list(p,JC69())))
# # create simulation object
# sim<-PhyloSim(root.seq=s, phylo=rcoal(2))
# # simulate and show alignment
# Simulate(sim)
# sim$alignment
# # check the rate multipliers and insertion tolerances in one of the sequences
# res<-sim$sequences[[2]]
# getRateMultipliers(res,p)
# getInsertionTolerance(res,p)
# }
#
# @author
#
# \seealso{
# DiscreteInsertor ContinuousInsertor GeneralInsertor GeneralInDel
# }
#
#*/###########################################################################
setConstructorS3(
"BrownianInsertor",
function(
name="Anonymous",
type="discrete",
scale=0.001,
...
) {
if(type == "continuous"){
this<-ContinuousInsertor(
...
);
}
else if (type == "discrete") {
this<-DiscreteInsertor(
...
);
}
else {
throw("Invalid insertor process type!\n");
}
this<-extend(
this,
"BrownianInsertor",
.scale = NA,
.type = type
);
# Using virtual field to clear Id cache:
this$name<-name;
# setting scale
this$scale<-scale;
this$generateBy<-function(process=NA,length=NA,target.seq=NA,event.pos=NA,insert.pos=NA){
if(is.na(target.seq)){
return(NA);
}
if(is.na(length) | (length(length) == 0) | length == 0){
throw("Invalid insert length!\n");
}
# The start and end of the Brownian path:
start;
end;
proc<-list();
if( (event.pos == 1) || (event.pos == target.seq$.length) ){
start<-clone(target.seq$.sites[[event.pos]]);
start$.state=NA;
end<-clone(start);
proc<-getProcesses(start);
} else {
start<-clone(target.seq$.sites[[insert.pos]]);
start$.state=NA;
end<-clone(target.seq$.sites[[insert.pos + 1]]);
end$.state=NA;
proc.start<-getProcesses(start);
proc.end<-getProcesses(end);
# Calculate the intersection of process list:
proc<-PSRoot$intersect.list(proc.start,proc.end);
# No common processes:
if(length(proc) == 0){
coin.flip<-sample(c(0,1),1);
if (coin.flip) {
proc <- getProcesses(start)
end <- clone(start)
} else {
proc <- getProcesses(end)
start <- clone(end)
}
}
}
# Create the insert sequence:
class.seq<-class(target.seq)[[1]];
insert<-do.call(class.seq,list(length=length));
setProcesses(this=insert,value=list(proc));
# For every process...
for (p in proc){
# ... and site specific parameter:
for(param in getSiteSpecificParamIds(p)){
start.value<-getParameterAtSite(p,site=start,id=param)$value;
end.value<-getParameterAtSite(p,site=end,id=param)$value;
path<-seq(from=start.value,to=end.value,length.out=(insert$.length + 2));
path<-path[2:(length(path)-1)];
brownian.path<-abs(BrownianInsertor$BrownianPath(p=path, a=this$.scale));
# Tolerance values are probabilities, do not alow them to wander beyond 1:
if(param == "insertion.tolerance" || param == "deletion.tolerance"){
brownian.path[which(brownian.path > 1)]<-1;
}
setParameterAtSites(
insert,
process = p,
id = param,
value = brownian.path
);
}
}
return(insert);
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="BrownianInsertor",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
this$scale<-this$scale;
if( (this$.type != "discrete") && (this$.type != "continuous") ){
throw("BrownianInsertor type is invalid!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: BrownianPath
##
###########################################################################/**
#
# @RdocMethod BrownianPath
#
# @title "Generate a Brownian path"
#
# \description{
# @get "title".
#
# This method generates a Brownian path given the scale parameter a (determining "noisiness")
# and the vector p describing the trends. More useful as a static method.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A BrownianInsertor object.}
# \item{p}{Path parameter (a numeric vector).}
# \item{a}{Scale paramater (a numeric vector of length one).}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector.
# }
#
# \examples{
# path<-BrownianInsertor$BrownianPath(a=2,p=1:10);
# path
# plot(path)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"BrownianPath",
class="BrownianInsertor",
function(
this,
p=NA,
a=NA,
...
){
generate_brownian<-function(length, a){
cumsum(rnorm(length,0,sd=a));
}
generate_bridge <- function (length,a){
b <- generate_brownian(length,a)
b - (1:length)/(length) * b[length]
}
generate_path <- function (p,a){
n <- length(p);
b <- generate_bridge (n+1,a);
p + b[1:n];
}
return(generate_path(p,a));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning"
);
##
## Method: getType
##
###########################################################################/**
#
# @RdocMethod getType
#
# @title "Get the type of the BrownianInsertor process"
#
# \description{
# @get "title".
#
# If type is \code{discrete}, than the process inherits from \code{DiscreteInsertor}.
# If the type is \code{continuous}, then the object inherits from \code{ContinuousInsertor}.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A BrownianInsertor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# p<-BrownianInsertor(type="discrete")
# # get type
# getType(p)
# # get upstream classes
# class(p)
# p<-BrownianInsertor(type="continuous")
# # get type via virtual field
# p$type
# # get upstream classes
# class(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getType",
class="BrownianInsertor",
function(
this,
...
){
this$.type;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setType
##
###########################################################################/**
#
# @RdocMethod setType
#
# @title "Forbidden action: setting the type of a BrownianInsertor object"
#
# \description{
# @get "title".
#
# The type can be set only from the \code{type} constructor argument and cannot be changed later.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setType",
class="BrownianInsertor",
function(
this,
value,
...
){
throw("The type of the BrownianInsertor objects can be set only from the constructor!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getScale
##
###########################################################################/**
#
# @RdocMethod getScale
#
# @title "Get scale parameter"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A BrownianInsertor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a BrownianInsertor object
# p<-BrownianInsertor(scale=0.002)
# # set/get scale parameter
# setScale(p,0.1)
# getScale(p)
# # set/get scale parameter via virtual field
# p$scale<-0.1
# p$scale
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getScale",
class="BrownianInsertor",
function(
this,
...
){
this$.scale;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setScale
##
###########################################################################/**
#
# @RdocMethod setScale
#
# @title "Set scale parameter"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A BrownianInsertor object.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# value (invisible).
# }
#
# \examples{
# # create a BrownianInsertor object
# p<-BrownianInsertor(scale=0.002)
# # set/get scale parameter
# setScale(p,0.1)
# getScale(p)
# # set/get scale parameter via virtual field
# p$scale<-0.1
# p$scale
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setScale",
class="BrownianInsertor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!is.numeric(value) || (length(value) != 1)){
throw("The value of the scale paramter must be a numeric vector of length 1!\n");
}
this$.scale<-value;
return(invisible(this$.scale));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# p<-BrownianInsertor(
# type="discrete",
# scale=0.05,
# sizes=1:4,
# probs=c(3/6,1/6,1/6,1/6),
# rate=0.05
# )
# # get a summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="BrownianInsertor",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
this$.summary$"Type"<-this$.type;
this$.summary$"Brownian path scale parameter"<-this$.scale;
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##
## CodonAlphabet
##
##########################################################################/**
#
# @RdocClass CodonAlphabet
#
# @title "The CodonAlphabet class"
#
# \description{
# This class implements codon alphabets and handles the translation of codons
# to their corresponding amino acids. Stop codons are excluded from the symbol set,
# thus the symbol set depends on the genetic code table.
# The genetic code table can be specified through the \code{table.id} constructor parameter.
#
# The available genetic code tables:
# \preformatted{
# 1 Standard
# 2 Vertebrate Mitochondrial
# 3 Yeast Mitochondrial
# 4 Mold, Protozoan, and CoelenterateMitochondrial and Mycoplasma/Spiroplasma
# 5 Invertebrate Mitochondrial
# 6 Ciliate, Dasycladacean and Hexamita Nuclear
# 9 Echinoderm Mitochondrial
# 10 Euplotid Nuclear
# 11 Bacterial
# 12 Alternative Yeast Nuclear
# 13 Ascidian Mitochondrial
# 14 Flatworm Mitochondrial
# 15 Blepharisma Nuclear
# 16 Chlorophycean Mitochondrial
# 21 Trematode Mitochondrial
# 22 Scenedesmus obliquus Mitochondrial
# 23 Thraustochytrium Mitochondrial
# }
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{table.id}{The identifier of the genetic code table.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a CodonAlphabet object
# a<-CodonAlphabet(table.id=2)
# # get object summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setConstructorS3(
"CodonAlphabet",
function(table.id=1,...){
# Genetic code tables, ripped from BioPerl. #
CODON.TABLES<-list(
'1'=list(
'name'='Standard',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='START'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='*',
type='STOP'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='START'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='I',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='R',
type='ORDINARY'
),
'AGG'=list(
aa='R',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='ORDINARY'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'2'=list(
'name'='Vertebrate Mitochondrial',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='W',
type='ORDINARY'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='START'
),
'ATC'=list(
aa='I',
type='START'
),
'ATA'=list(
aa='M',
type='START'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='*',
type='STOP'
),
'AGG'=list(
aa='*',
type='STOP'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='START'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'3'=list(
'name'='Yeast Mitochondrial',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='W',
type='ORDINARY'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='T',
type='ORDINARY'
),
'CTC'=list(
aa='T',
type='ORDINARY'
),
'CTA'=list(
aa='T',
type='ORDINARY'
),
'CTG'=list(
aa='T',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='M',
type='START'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='R',
type='ORDINARY'
),
'AGG'=list(
aa='R',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='ORDINARY'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'4'=list(
'name'='Mold, Protozoan, and CoelenterateMitochondrial and Mycoplasma/Spiroplasma',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='START'
),
'TTG'=list(
aa='L',
type='START'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='W',
type='ORDINARY'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='START'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='START'
),
'ATC'=list(
aa='I',
type='START'
),
'ATA'=list(
aa='I',
type='START'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='R',
type='ORDINARY'
),
'AGG'=list(
aa='R',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='START'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'5'=list(
'name'='Invertebrate Mitochondrial',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='START'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='W',
type='ORDINARY'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='START'
),
'ATC'=list(
aa='I',
type='START'
),
'ATA'=list(
aa='M',
type='START'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='S',
type='ORDINARY'
),
'AGG'=list(
aa='S',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='START'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'6'=list(
'name'='Ciliate, Dasycladacean and Hexamita Nuclear',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='Q',
type='ORDINARY'
),
'TAG'=list(
aa='Q',
type='ORDINARY'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='*',
type='STOP'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='I',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='R',
type='ORDINARY'
),
'AGG'=list(
aa='R',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='ORDINARY'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'9'=list(
'name'='Echinoderm Mitochondrial',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='W',
type='ORDINARY'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='I',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='N',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='S',
type='ORDINARY'
),
'AGG'=list(
aa='S',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='ORDINARY'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'10'=list(
'name'='Euplotid Nuclear',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='C',
type='ORDINARY'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='I',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='R',
type='ORDINARY'
),
'AGG'=list(
aa='R',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='ORDINARY'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'11'=list(
'name'='Bacterial',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='START'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='*',
type='STOP'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='START'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='START'
),
'ATC'=list(
aa='I',
type='START'
),
'ATA'=list(
aa='I',
type='START'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='R',
type='ORDINARY'
),
'AGG'=list(
aa='R',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='START'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'12'=list(
'name'='Alternative Yeast Nuclear',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='*',
type='STOP'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='S',
type='START'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='I',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='R',
type='ORDINARY'
),
'AGG'=list(
aa='R',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='ORDINARY'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'13'=list(
'name'='Ascidian Mitochondrial',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='W',
type='ORDINARY'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='M',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='G',
type='ORDINARY'
),
'AGG'=list(
aa='G',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='ORDINARY'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'14'=list(
'name'='Flatworm Mitochondrial',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='Y',
type='ORDINARY'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='W',
type='ORDINARY'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='I',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='N',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='S',
type='ORDINARY'
),
'AGG'=list(
aa='S',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='ORDINARY'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'15'=list(
'name'='Blepharisma Nuclear',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='Q',
type='ORDINARY'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='*',
type='STOP'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='I',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='R',
type='ORDINARY'
),
'AGG'=list(
aa='R',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='ORDINARY'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'16'=list(
'name'='Chlorophycean Mitochondrial',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='L',
type='ORDINARY'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='*',
type='STOP'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='I',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='R',
type='ORDINARY'
),
'AGG'=list(
aa='R',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='ORDINARY'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'21'=list(
'name'='Trematode Mitochondrial',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='W',
type='ORDINARY'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='M',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='N',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='S',
type='ORDINARY'
),
'AGG'=list(
aa='S',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='START'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'22'=list(
'name'='Scenedesmus obliquus Mitochondrial',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='L',
type='ORDINARY'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='*',
type='STOP'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='L',
type='ORDINARY'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='*',
type='STOP'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='ORDINARY'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='I',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='R',
type='ORDINARY'
),
'AGG'=list(
aa='R',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='ORDINARY'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
),
'23'=list(
'name'='Thraustochytrium Mitochondrial',
'trans'=list(
'TTT'=list(
aa='F',
type='ORDINARY'
),
'TTC'=list(
aa='F',
type='ORDINARY'
),
'TTA'=list(
aa='*',
type='STOP'
),
'TTG'=list(
aa='L',
type='ORDINARY'
),
'TCT'=list(
aa='S',
type='ORDINARY'
),
'TCC'=list(
aa='S',
type='ORDINARY'
),
'TCA'=list(
aa='S',
type='ORDINARY'
),
'TCG'=list(
aa='S',
type='ORDINARY'
),
'TAT'=list(
aa='Y',
type='ORDINARY'
),
'TAC'=list(
aa='Y',
type='ORDINARY'
),
'TAA'=list(
aa='*',
type='STOP'
),
'TAG'=list(
aa='*',
type='STOP'
),
'TGT'=list(
aa='C',
type='ORDINARY'
),
'TGC'=list(
aa='C',
type='ORDINARY'
),
'TGA'=list(
aa='*',
type='STOP'
),
'TGG'=list(
aa='W',
type='ORDINARY'
),
'CTT'=list(
aa='L',
type='ORDINARY'
),
'CTC'=list(
aa='L',
type='ORDINARY'
),
'CTA'=list(
aa='L',
type='ORDINARY'
),
'CTG'=list(
aa='L',
type='ORDINARY'
),
'CCT'=list(
aa='P',
type='ORDINARY'
),
'CCC'=list(
aa='P',
type='ORDINARY'
),
'CCA'=list(
aa='P',
type='ORDINARY'
),
'CCG'=list(
aa='P',
type='ORDINARY'
),
'CAT'=list(
aa='H',
type='ORDINARY'
),
'CAC'=list(
aa='H',
type='ORDINARY'
),
'CAA'=list(
aa='Q',
type='ORDINARY'
),
'CAG'=list(
aa='Q',
type='ORDINARY'
),
'CGT'=list(
aa='R',
type='ORDINARY'
),
'CGC'=list(
aa='R',
type='ORDINARY'
),
'CGA'=list(
aa='R',
type='ORDINARY'
),
'CGG'=list(
aa='R',
type='ORDINARY'
),
'ATT'=list(
aa='I',
type='START'
),
'ATC'=list(
aa='I',
type='ORDINARY'
),
'ATA'=list(
aa='I',
type='ORDINARY'
),
'ATG'=list(
aa='M',
type='START'
),
'ACT'=list(
aa='T',
type='ORDINARY'
),
'ACC'=list(
aa='T',
type='ORDINARY'
),
'ACA'=list(
aa='T',
type='ORDINARY'
),
'ACG'=list(
aa='T',
type='ORDINARY'
),
'AAT'=list(
aa='N',
type='ORDINARY'
),
'AAC'=list(
aa='N',
type='ORDINARY'
),
'AAA'=list(
aa='K',
type='ORDINARY'
),
'AAG'=list(
aa='K',
type='ORDINARY'
),
'AGT'=list(
aa='S',
type='ORDINARY'
),
'AGC'=list(
aa='S',
type='ORDINARY'
),
'AGA'=list(
aa='R',
type='ORDINARY'
),
'AGG'=list(
aa='R',
type='ORDINARY'
),
'GTT'=list(
aa='V',
type='ORDINARY'
),
'GTC'=list(
aa='V',
type='ORDINARY'
),
'GTA'=list(
aa='V',
type='ORDINARY'
),
'GTG'=list(
aa='V',
type='START'
),
'GCT'=list(
aa='A',
type='ORDINARY'
),
'GCC'=list(
aa='A',
type='ORDINARY'
),
'GCA'=list(
aa='A',
type='ORDINARY'
),
'GCG'=list(
aa='A',
type='ORDINARY'
),
'GAT'=list(
aa='D',
type='ORDINARY'
),
'GAC'=list(
aa='D',
type='ORDINARY'
),
'GAA'=list(
aa='E',
type='ORDINARY'
),
'GAG'=list(
aa='E',
type='ORDINARY'
),
'GGT'=list(
aa='G',
type='ORDINARY'
),
'GGC'=list(
aa='G',
type='ORDINARY'
),
'GGA'=list(
aa='G',
type='ORDINARY'
),
'GGG'=list(
aa='G',
type='ORDINARY'
)
)
)
);
# end of genetic code tables #
table.id<-as.character(table.id);
# Figure out the symbols set by excluding stop codons:
symbols<-character();
for (codon in names(CODON.TABLES[[table.id]]$trans)) {
if(CODON.TABLES[[table.id]]$trans[[codon]]$type != "STOP") {
symbols<-c(symbols,codon);
}
}
this<-Alphabet(
type=CODON.TABLES[[table.id]]$name,
symbols=symbols
);
this<-extend(this,
"CodonAlphabet",
.table.id=table.id,
.trans.table=CODON.TABLES[[table.id]]$trans,
.is.codon.alphabet=TRUE
);
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="CodonAlphabet",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if(!is.character(this$.table.id) | (length(this$.table.id) != 1) ) {
throw(".table.id inconsistency!\n");
}
if(!is.list(this$.trans.table)){
throw("Translation table is not a list!\n");
}
for (tmp in this$.trans.table){
if (length(intersect(names(tmp),c("aa","type"))) != 2){
throw("Translation table contains invalid entries!\n");
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getTableId
##
###########################################################################/**
#
# @RdocMethod getTableId
#
# @title "Get the genetic code id"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonAlphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create CodonAlphabet object
# a<-CodonAlphabet()
# # get genetic code id
# getTableId(a)
# # get genetic code id via virtual field
# a$tableId
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getTableId",
class="CodonAlphabet",
function(
this,
...
){
this$.table.id;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setTableId
##
###########################################################################/**
#
# @RdocMethod setTableId
#
# @title "Forbidden action: setting the genetic code id"
#
# \description{
# @get "title".
# Use the \code{table.id} constructor argument to set the genetic code.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setTableId",
class="CodonAlphabet",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: translateCodon
##
###########################################################################/**
#
# @RdocMethod translateCodon
#
# @title "Translate a codon"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonAlphabet object.}
# \item{codon}{The codon to be translated.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector containing an amino acid IUPAC code.
# }
#
# \examples{
# # create a CodonAlphabet object
# a<-CodonAlphabet()
# # translate a codon
# translateCodon(a,"AGG")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"translateCodon",
class="CodonAlphabet",
function(
this,
codon,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(codon)){
throw("No codon given!\n");
}
else if (!is.character(codon) | (length(codon) != 1)){
throw("The codon argument must be a character vector of size 1!\n");
}
else if (length(intersect(names(this$.trans.table),codon)) != 1){
throw("Codon not in translation table!\n");
}
else if (this$.trans.table[[codon]]$type == "STOP"){
return("*");
}
else {
return(this$.trans.table[[codon]]$aa);
}
} else {
return(this$.trans.table[[codon]]$aa);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: isStopCodon
##
###########################################################################/**
#
# @RdocMethod isStopCodon
#
# @title "Check if a codon is a stop codon"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonAlphabet object.}
# \item{codon}{The codon to be checked.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create a CodonAlphabet object
# a<-CodonAlphabet()
# # check some codons
# isStopCodon(a,"ATG")
# isStopCodon(a,"TGA")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"isStopCodon",
class="CodonAlphabet",
function(
this,
codon,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(codon)){
throw("No codon given!\n");
}
else if (!is.character(codon) | (length(codon) != 1)){
throw("The codon argument must be a character vector of size 1!\n");
}
else if (length(intersect(names(this$.trans.table),codon)) != 1){
throw("Codon not in translation table!\n");
}
}
if (this$.trans.table[[codon]]$type == "STOP"){
return(TRUE);
}
else {
return(FALSE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: isStartCodon
##
###########################################################################/**
#
# @RdocMethod isStartCodon
#
# @title "Check if a codon is a start codon"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonAlphabet object.}
# \item{codon}{The codon to be checked.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create a CodonAlphabet object
# a<-CodonAlphabet()
# # check some codons
# isStartCodon(a,"ATG")
# isStartCodon(a,"TGA")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"isStartCodon",
class="CodonAlphabet",
function(
this,
codon,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(codon)){
throw("No codon given!\n");
}
else if (!is.character(codon) | (length(codon) != 1)){
throw("The codon argument must be a character vector of size 1!\n");
}
else if (length(intersect(names(this$.trans.table),codon)) != 1){
throw("Codon not in translation table!\n");
}
}
if (this$.trans.table[[codon]]$type == "START"){
return(TRUE);
}
else {
return(FALSE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: areSynonymous
##
###########################################################################/**
#
# @RdocMethod areSynonymous
#
# @title "Check whether two codons are synonymous"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonAlphabet object.}
# \item{codons}{A vector containing two codons.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create a CodonAlphabet object
# a<-CodonAlphabet()
# areSynonymous(a,c("TCC","TCT"))
# areSynonymous(a,c("TCC","CCT"))
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"areSynonymous",
class="CodonAlphabet",
function(
this,
codons,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(codons)){
throw("No codons given!\n");
}
else if (!is.character(codons) | (length(codons) != 2)){
throw("The codons argument must be a character vector of size 2!\n");
}
}
if (translateCodon(this,codons[1]) == translateCodon(this,codons[2])){
return(TRUE);
}
else {
return(FALSE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .codonDiff
##
setMethodS3(
".codonDiff",
class="CodonAlphabet",
function(
this,
codons,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(codons)){
throw("No codons given!\n");
}
else if (!is.character(codons) | (length(codons) != 2)){
throw("The codons argument must be a character vector of size 2!\n");
}
else if (length(intersect(names(this$.trans.table),codons[1])) != 1){
throw("Codon 1 is not in translation table!\n");
}
else if (length(intersect(names(this$.trans.table),codons[2])) != 1){
throw("Codon 2 is not in translation table!\n");
}
}
purines<-c("A","G");
pyrimidines<-c("C","T");
res<-character();
codon1<-strsplit(codons[1],"",fixed=TRUE)[[1]];
codon2<-strsplit(codons[2],"",fixed=TRUE)[[1]];
for(i in c(1,2,3)){
if(codon1[i] == codon2[i]) {
res[i]<-0;
}
else if ( length(intersect(purines,c(codon1[i],codon2[i]))) == 2 | length(intersect(pyrimidines,c(codon1[i],codon2[i]))) == 2 ){
res[i]<-"TI";
} else {
res[i]<-"TV";
}
}
return(res);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-CodonAlphabet()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="CodonAlphabet",
function(
object,
...
){
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getTransTable
##
###########################################################################/**
#
# @RdocMethod getTransTable
#
# @title "Get the list storing the genetic code table"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonAlphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list.
# }
#
# \examples{
# # create object
# a<-CodonAlphabet()
# # get genetic code table
# getTransTable(a)
# # get genetic code table via virtual field
# a$transTable
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getTransTable",
class="CodonAlphabet",
function(
this,
...
){
this$.trans.table
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setTransTable
##
###########################################################################/**
#
# @RdocMethod setTransTable
#
# @title "Forbidden action: setting the genetic code table for a CodonAlphabet object"
#
# \description{
# @get "title".
# Use the \code{table.id} constructor argument to set the genetic code.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setTransTable",
class="CodonAlphabet",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: is.CodonAlphabet
##
###########################################################################/**
#
# @RdocDefault is.CodonAlphabet
#
# @title "Check if an object inherits from CodonAlphabet"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
#
# }
#
# \value{
# TRUE of FALSE.
# }
#
# \examples{
# # create some objects
# a<-CodonAlphabet()
# p<-Process()
# # check if they inherit from CodonAlphabet
# is.CodonAlphabet(a)
# is.CodonAlphabet(p)
# }
#
# @author
#
#*/###########################################################################
setMethodS3(
"is.CodonAlphabet",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
else if(!is.null(this$.is.codon.alphabet)){return(TRUE)}
else if ( inherits(this, "CodonAlphabet")) {
this$.is.codon.alphabet<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##
## CodonUNREST
##
##########################################################################/**
#
# @RdocClass CodonUNREST
#
# @title "The CodonUNREST class"
#
# \description{
# This class implements a time-continuous Markov process acting on a state
# space defined by the symbol set of a CodonAlphabet object. The rate matrix of this model
# is unrestricted, so it can be used to implement empircal codon models or more
# restricted mechanistic models.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{table.id}{The identifier of the genetic code table (see \code{CodonAlphabet}).}
# \item{rate.list}{A list of unscaled substitution rates (see \code{setRateList.GeneralSubstitution}).}
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a CodonUNREST object
# p<-CodonUNREST(table.id=2)
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# GeneralSubstitution GY94
# }
#
#*/###########################################################################
setConstructorS3(
"CodonUNREST",
function(
name="Anonymous", # name of the object
table.id=1, # the id of the genetic code table to use
rate.list=NA, # list of unscaled rates
equ.dist=NA, # equlibrium distribution
...
) {
got.rate.list<-!missing(rate.list);
got.equ.dist<-!missing(equ.dist);
this<-NA;
# Got rate list and equlibrium distribution:
if(got.rate.list & got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=CodonAlphabet(table.id=table.id),
rate.list=rate.list,
equ.dist=equ.dist
);
}
# Got rate list
else if(got.rate.list & !got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=CodonAlphabet(table.id=table.id),
rate.list=rate.list
);
}
# Got equlibrium distribution,
# we set it, but it will be owerwritten anyway.
else if(!got.rate.list & got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=CodonAlphabet(table.id=table.id),
equ.dist=equ.dist
);
}
# Got nothing:
else if(!got.rate.list & !got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=CodonAlphabet(table.id=table.id)
);
}
this<-extend(this, "CodonUNREST");
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
##
setMethodS3(
"checkConsistency",
class="CodonUNREST",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if(!inherits(this$alphabet, "CodonAlphabet")){
throw("This object must have as alphabet a CodonAlphabet object!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
# Method: is.CodonUNREST
##
###########################################################################/**
#
# @RdocDefault is.CodonUNREST
#
# @title "Check whether an object inherits from CodonUNREST"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
#
# }
#
# \value{
# TRUE of FALSE.
# }
#
# \examples{
# # create some objects
# p<-CodonUNREST()
# pp<-GTR()
# # check if they inherit from CodonUNREST
# is.CodonUNREST(p)
# is.CodonUNREST(pp)
# }
#
# @author
#
#*/###########################################################################
setMethodS3(
"is.CodonUNREST",
class="default",
function(
this,
...
){
if(!is.GeneralSubstitution(this)) {return(FALSE)}
if ( inherits(this, "CodonUNREST")) {
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## GY94
##
##########################################################################/**
#
# @RdocClass GY94
#
# @title "The GY94 class"
#
# \description{
# This class implements the codon substitution model of Goldman and Yang (1994).
# The transition/transversion rate ratio is stored in the \code{kappa} virtual field.
# The nonsynonymous/synonymous substitution rate ratio (\code{omega}) is a site-process specific parameter
# with a default value of one.
# Hence, after the attachment of the process the variation of omega ratios among sites follows
# the M0 model (see Yang et al. 2000).
#
# The rate matrix of the \code{\link{GY94}} model is scaled in a way that the expected number
# of potential substiutions per site is equal to one at equlibrium.
# The \emph{codeml} program from the PAML package scales the rate matrix in order to have
# the expected number of accepted substiutions per site equal to one. Use the
# \code{\link{getOmegaScalingFactor.GY94}} method to claculate a branch length scaling factor
# which allows to switch to a PAML-style scaling given an average omega.
#
# If the \code{scale.nuc} constructor argument is TRUE, the rates of the returned \code{Event} objects
# will be multiplied by \code{3} to obtain a process which has the expected number of nucleotide substitutions
# (not \code{codon} substitutions) equal to one at equilibrium. This is useful when simulating
# mixed sequences. This option doesn't affect the rate matrix in any way.
#
# The M1-M4 models are implemented in the \code{omegaVarM[1-4].CodonSeqeunce} methods.
# Simulations under more complex models (M5-M13) can be achieved by first discretizing them
# using the \code{M5-13} tool from the INDELible software
# package (\url{http://abacus.gene.ucl.ac.uk/software/indelible/}).
# After discretization, the M5-M13 models can be simulated through the M3 (discrete) model.
#
# @classhierarchy
# }
#
# \references{
# Goldman, N., Yang, Z. (1994) A codon-based model of nucleotide substitution for protein-coding DNA sequences - Mol Biol Evol 11(5):725-36 \url{http://bit.ly/aSVEoa}
#
# Yang, Z., Nielsen, R., Goldman, N., Pedersen Krabbe, A-M. (2000) Codon-Substitution Models for Heterogeneous Selection Pressure at Amino Acid Sites - Genetics 155:431-449 \url{http://bit.ly/bvjucn}
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Name of the object.}
# \item{table.id}{The identifier of the genetic code table to use (1 by default).}
# \item{kappa}{The transition/transversion rate ratio (1 by default).}
# \item{omega.default}{The default value of the omega site-process specific parameter (1 by default).}
# \item{codon.freqs}{A vector of codon frequencies.}
# \item{scale.nuc}{Scale to nucleotide substitutions if TRUE (see above).}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a GY94 object
# p<-GY94(kappa=2)
# # check if inherits from GY94
# is.GY94(p)
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
# # create a codon sequence, attach process
# s<-CodonSequence(length=5, processes=list(list(p)))
# # sample states
# sampleStates(s)
# # make first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # sample omega values from the M3 (discrete) model.
# omegaVarM3(s,p,omegas=c(0,1,2,3),probs=c(2/5,1/5,1/5,1/5))
# # get a histogram of omega values in s
# omegaHist(s,p,breaks=50)
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # get the list of recorded per-branch event counts
# getBranchEvents(sim)
# # export the number of synonymous substitutions as a phylo object
# syn.subst<-exportStatTree(sim,"nr.syn.subst")
# syn.subst
# # plot the exported phylo object
# plot(syn.subst)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# CodonUNREST GeneralSubstitution CodonSequence GTR WAG
# }
#
#*/###########################################################################
setConstructorS3(
"GY94",
function(
name="Anonymous", # name of the object
table.id=1, # id of the genetic code table to use
kappa=1, # transition/transversion rate ratio
omega.default=1, # the default value of the omega site-process specific parameter
codon.freqs=NA, # codon frequencies
scale.nuc=FALSE, # scale Q matrix to nucleotide substitutions
...
) {
# Create a CodonUNREST object.
this<-CodonUNREST(table.id=table.id);
# Set codon frequencies to uniform if they are not provided:
if(missing(codon.freqs)){
codon.freqs<-rep((1/this$alphabet$size),this$alphabet$size);
}
# Extend:
this<-extend(
this,
"GY94",
.kappa=NA,
.is.ny98=TRUE,
.scale.const=as.double(1.0),
.syn.cache=NA
);
# Add the "omega" site-process specific parameter:
.addSiteSpecificParameter(
this,
id="omega",
name="Omega",
value=as.double(omega.default),
type="numeric"
);
# Set the codon frequencies/equilibrium distribution.
setEquDist(this,value=codon.freqs,force=TRUE);
# Set kappa:
this$kappa<-kappa;
# Scale to nucleotide if requested:
if(scale.nuc){
this$.scale.const<-as.double(3.0);
}
# Set object name:
this$name<-name;
# Force clearing id cache:
this$name<-this$name;
# create syn/nsyn matrix cache
# Get translation table:
trans.table<-this$.alphabet$.trans.table;
symbols<-this$.alphabet$symbols;
syn.cache<-matrix(nrow=this$.alphabet$size,ncol=this$.alphabet$size);
colnames(syn.cache)<-symbols;
rownames(syn.cache)<-symbols;
for(i in symbols){
for(j in symbols){
if(i == j) { next }
if( (trans.table[[i]]$aa) == (trans.table[[j]]$aa) ){
syn.cache[i,j]<-1;
}
else{
syn.cache[i,j]<-0;
}
}
}
this$.syn.cache<-syn.cache;
return(this);
},
enforceRCC=TRUE
);
##
## Method: is.GY94
##
###########################################################################/**
#
# @RdocDefault is.GY94
#
# @title "Check whether an object inherits from GY94"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE of FALSE.
# }
#
# \examples{
# # create some objects
# p<-CodonUNREST()
# pp<-GY94()
# # check if they inherit from CodonUNREST
# is.GY94(p)
# is.GY94(pp)
# }
#
# @author
#
#*/###########################################################################
setMethodS3(
"is.GY94",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.ny98)){return(TRUE)}
if ( inherits(this, "GY94")) {
this$.is.process<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventsAtSite.GY94
##
###########################################################################/**
#
# @RdocMethod getEventsAtSite
#
# @title "Generate the list of active Event objects for a given attached Site object"
#
# \description{
# @get "title".
#
# This method is almost an exact duplicate of the getEventsAtSite.GeneralSubstitution,
# with the exception of the portions dealing with the omega site-process specific parameter.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GY94 object.}
# \item{target.site}{A Site object. The GY94 object must be attached to the Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of the active Event objects.
# }
#
#
# @author
#
# \seealso{
# getEventsAtSite.GeneralSubstitution GeneralSubstitution
# }
#
#*/###########################################################################
setMethodS3(
"getEventsAtSite",
class="GY94",
function(
this,
target.site,
...
){
if (!exists(x="PSIM_FAST")) {
if(!is.Site(target.site)) {
throw("Target site invalid!\n");
}
if(is.na(this$.q.matrix)){
throw("Cannot provide event objects because the rate matrix is not set!\n");
}
if(!is.numeric(this$.equ.dist)){
throw("Cannot provide event objects because the equilibrium frequencies are not defined!\n");
}
}
state<-as.character(target.site$.state);
# Just return an empty list if the state is NA:
if(is.na(state)){
return(list());
}
# Get rate matrix:
rate.matrix<-this$.q.matrix$.rate.matrix;
# Get translation table:
trans.table<-target.site$.alphabet$.trans.table;
# Get scaling constant:
scale.const<-this$.scale.const;
# get syn cache:
syn.cache<-this$.syn.cache;
symbols<-this$.alphabet$.symbols;
rest<-symbols[ which(symbols != state) ];
# Create the event objects:
events<-list();
# The rate of the event is the product of the general rate and the
# site-process specific rate multiplier:
rate.multiplier<-target.site$.processes[[this$.id]]$site.params[["rate.multiplier"]]$value;
# Return empty list if the rate multiplier is zero.
if(rate.multiplier == 0 ) {
return(list());
}
# Get the omega site-process specific parameter:
omega<-target.site$.processes[[this$.id]]$site.params[["omega"]]$value;
for(new.state in rest){
# Get the base rate:
base.rate<-rate.matrix[state,new.state];
# Skip event if base rate is zero:
if(base.rate == 0){
next;
}
name<-paste(state,new.state,sep="->");
# Clone the event template object:
event<-clone(this$.event.template);
# Set event name:
event$.name<-name;
# Set the generator process:
event$.process<-this;
# Set the target position passed in a temporary field,
# Event objects are not aware of their posiitions in general!
event$.position<-target.site$.position;
# Set the target site:
event$.site<-target.site;
# Figure out wether the event is a synonymous mutation ...
if( syn.cache[state,new.state] ){
# and ignore omega in that case
event$.rate<-(scale.const * rate.multiplier * base.rate);
# Mark substitution as synonymous.
event$.type<-"synonymous";
} else {
# incorporate omega otherwise
event$.rate<-(scale.const * rate.multiplier * omega * base.rate);
# Mark substitution as non-synonymous.
event$.type<-"non-synonymous";
}
# Set the handler for the substitution event:
event$.handler<-this$.handler.template;
# Add to events list:
events<-c(events, list(event));
}
return(events);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="GY94",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# Check kappa:
if(!is.numeric(this$.kappa)){
throw("Kappa must be numeric!\n");
}
# Check codon.freqs
this$codonFreqs<-this$codonFreqs;
# Check rate sanity:
symbols<-this$alphabet$symbols;
alphabet<-this$alphabet;
for(from in symbols){
for(to in symbols){
# Skip diagonal elements:
if(from == to) {next()};
# Figure out codon differences:
diff<-sort(.codonDiff(alphabet, c(from,to)));
# Single transition:
if( all(diff == sort(c(0,0,"TI"))) ){
if( !PSRoot$my.all.equal ( this$.q.matrix$.orig.matrix[from, to], (this$.kappa * this$.equ.dist[1,to]) ) ){
throw("GY94 rate inconsistency. From:",from," To:",to,"!\n");
}
}
# Single transversion:
else if( all(diff == sort(c(0,0,"TV"))) ){
if( !PSRoot$my.all.equal ( this$.q.matrix$.orig.matrix[from, to], (this$.equ.dist[1,to]) ) ){
throw("GY94 rate inconsistency. From:",from," To:",to,"!\n");
}
}
# Multiple nucleotide substitution:
else {
if( this$.q.matrix$.orig.matrix[from, to] != 0.0 ){
throw("GY94 rate inconsistency. From:",from," To:",to,"!\n");
}
}
} #/for to
} #/for from
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
###########################################################################/**
#
# @RdocMethod getOmegaScalingFactor
#
# @title "Get the omega scaling factor"
#
# \description{
# @get "title".
#
# The rate matrix of the \code{\link{GY94}} model is scaled in a way that the expected number
# of potential substiutions per site is equal to one at equlibrium.
# The \emph{codeml} program from the PAML package scales the rate matrix in order to have
# the expected number of accepted substiutions per site equal to one.
#
# This method calculates the branch length multiplier needed for switching
# to PAML-style scaling given a fixed omega.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GY94 object.}
# \item{omega}{The value of omega.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # construct a GY94 process object
# p<-GY94(kappa=4)
# # Calculate scaling factor for omega=2
# getOmegaScalingFactor(p,omega=2)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getOmegaScalingFactor",
class="GY94",
function(
this,
omega,
...
){
if(missing(omega)){
throw("No omega provided!");
}
if(!is.numeric(omega)){
throw("Omega must be numeric!");
}
neutral.K<-0.0;
K <- 0.0;
# get the symbols:
symbols<-this$.alphabet$symbols;
# Get translation table and rate matrix:
trans.table<-this$.alphabet$.trans.table;
rate.matrix<-this$.q.matrix$.rate.matrix;
# For every symbol:
for (i in symbols) {
# Get the equlibrium probability:
i.equ<-this$.equ.dist[[ which(colnames(this$.equ.dist) == i) ]];
for(j in symbols){
if(i == j){next}
base.rate<-rate.matrix[i,j];
neutral.K<- neutral.K + (i.equ * base.rate);
if( (trans.table[[i]]$aa) == (trans.table[[j]]$aa) ){
K <- K + (i.equ * base.rate);
}
else {
K <- K + (i.equ * omega * base.rate);
}
}
}
return(neutral.K/K);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .buildGY94Rates
##
setMethodS3(
".buildGY94Rates",
class="GY94",
function(
this,
...
){
# Wiping out the rate matrices to prevent rescaling after
# modifying an individual rate. This could be more elegant.
# Wiping out the original rate matrix:
this$QMatrix$.orig.matrix[]<-NA;
# Wiping out the scaled rate matrix:
this$QMatrix$.rate.matrix[]<-NA;
alphabet<-this$.alphabet;
symbols<-alphabet$symbols;
purines<-c("A","G");
pyrimidines<-c("C","T");
for(i in symbols){
for(j in symbols){
# Split codons:
nuc.i<-strsplit(i,"",fixed=TRUE)[[1]];
nuc.j<-strsplit(j,"",fixed=TRUE)[[1]];
diff<-which( (nuc.i == nuc.j) == FALSE);
# Skip diagonal elements:
if( i == j) {
next;
}
else if( length( diff ) > 1){
# We have multiple nucleotiode substiutions:
this$.q.matrix$.orig.matrix[i,j]<-0;
}
else if (
length( intersect( purines, c(nuc.i[diff[1]],nuc.j[diff[1]])) ) == 2 |
length( intersect( pyrimidines, c(nuc.i[diff[1]],nuc.j[diff[1]])) ) == 2
){
# We have a single transition:
this$.q.matrix$.orig.matrix[i,j]<-(this$.kappa * this$.equ.dist[1,j]);
} else {
# The only possibility left is a single transversion:
this$.q.matrix$.orig.matrix[i,j]<-(this$.equ.dist[1,j]);
}
} # /for j
} # /for i
# Set the new diagonal element in the original rates matrix:
for(codon in symbols){
this$.q.matrix$.orig.matrix[codon, codon]<-.calculateDiagonal(this$.q.matrix, symbol=codon);
}
# Call rate rescaling, suppress equlibrium distribution guessing:
.callRateRescaling(this$.q.matrix,guess.equ=FALSE);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRate
##
###########################################################################/**
#
# @RdocMethod setRate
#
# @title "Set an unscaled rate for an event from a GY94 object"
#
# \description{
# @get "title".
#
# See \code{\link{setRate.GeneralSubstitution}}.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{name}{The name of the event.}
# \item{from}{The initial state.}
# \item{value}{The new value of the rate.}
# \item{to}{Target state.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRate",
class="GY94",
function(
this,
name=NA,
value,
from=NA,
to=NA,
...
){
.checkWriteProtection(this);
# Setting unscaled rate:
if(!exists(x="PSIM_FAST")) {
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot set rate as the rate matrix is undefined!\n");
}
}
if(!missing(name) & missing(from) & missing(to)){
return(setRate(this$.q.matrix, name=name, value=value,guess.equ=FALSE));
}
else if (missing(name) & !missing(from) & !missing(to)){
return(setRate(this$.q.matrix, from=from, to=to, value=value,guess.equ=FALSE));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getKappa
##
###########################################################################/**
#
# @RdocMethod getKappa
#
# @title "Get the transition/transversion rate ratio"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GY94 object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a GY94 object
# p<-GY94()
# # set/get kappa
# setKappa(p,2)
# getKappa(p)
# # set/get kappa via virtual field
# p$kappa<-3
# p$kappa
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getKappa",
class="GY94",
function(
this,
...
){
this$.kappa;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setKappa
##
###########################################################################/**
#
# @RdocMethod setKappa
#
# @title "Set the transition/transversion rate ratio"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GY94 object.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of kappa.
# }
#
# \examples{
# # create a GY94 object
# p<-GY94()
# # set/get kappa
# setKappa(p,2)
# getKappa(p)
# # set/get kappa via virtual field
# p$kappa<-3
# p$kappa
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setKappa",
class="GY94",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)){
throw("No new value provided");
}
else if (length(value) != 1 | !is.numeric(value)){
throw("The new value must be a numeric vector of length 1!\n");
}
}
this$.kappa<-value;
.buildGY94Rates(this);
return(value);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getCodonFreqs
##
###########################################################################/**
#
# @RdocMethod getCodonFreqs
#
# @title "Get codon frequencies"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GY94 object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix containing the codon frequencies.
# }
#
# \examples{
# # create a GY94 object
# p<-GY94()
# # get codon frequencies
# getCodonFreqs(p)
# p$codonFreqs
# # set codon frequencies
# p$codonFreqs<-rep(c(1,2,3,4),length.out=61)
# p$codonFreqs
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getCodonFreqs",
class="GY94",
function(
this,
...
){
this$.equ.dist;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setCodonFreqs
##
###########################################################################/**
#
# @RdocMethod setCodonFreqs
#
# @title "Get codon frequencies"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GY94 object.}
# \item{value}{A vector of codon frequencies.}
# \item{...}{Not used.}
# }
#
# \value{
# value (invisible)
# }
#
# \examples{
# # create a GY94 object
# p<-GY94()
# # get codon frequencies
# getCodonFreqs(p)
# p$codonFreqs
# # set codon frequencies
# p$codonFreqs<-rep(c(1,2,3,4),length.out=61)
# p$codonFreqs
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setCodonFreqs",
class="GY94",
function(
this,
value,
...
){
.checkWriteProtection(this);
setEquDist(this,value,force=TRUE);
.buildGY94Rates(this);
return(invisible(value));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.GY94
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-GY94(kappa=2)
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="GY94",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
this$.summary$"Kappa"<-this$.kappa;
this$.summary$"Genetic code table id"<-this$.alphabet$tableId;
.addSummaryAlphabet(this);
this$.summary$"Unscaled rate matrix"<-"not shown";
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass CodonSubst
#
# @title "The CodonSubst class"
#
# \description{
# This is a class implementing a continuous-time Markov process acting on
# the state-space defined by the \code{CodonAlphabet} class.
#
# The rate matrix can be built from PAML files specified by the \code{paml.file} argument.
# Alternatively the rates can be specified as a list through the \code{rate.list} parameter.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{paml.file}{The name of the PAML file used to construct the rate matrix.}
# \item{rate.list}{A list of unscaled substitution rates (see \code{setRateList.GeneralSubstitution}).}
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create an object
# p<-CodonSubst()
# # build rate matrix from paml file
# # buildFromPAML(p,"path_to_paml_file") # do not run this
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setConstructorS3(
"CodonSubst",
function(
name="Anonymous",
paml.file=NA,
rate.list=NA,
equ.dist=NA,
...
) {
got.rate.list<-!missing(rate.list);
got.equ.dist<-!missing(equ.dist);
extend.with.s<-function(this){
this<-extend(this, "CodonSubst",
.s.matrix=data.matrix(matrix(ncol=this$.alphabet$size,nrow=this$.alphabet$size)),
.paml.file=NA
);
rownames(this$.s.matrix)<-this$.alphabet$.symbols;
colnames(this$.s.matrix)<-this$.alphabet$.symbols;
# Setting diagonal elements to zero:
diag(this$.s.matrix)<-0;
return(this);
}
this<-NA;
if(missing(paml.file)){
# No PAML file given
# Got rate list and equlibrium distribution:
if(got.rate.list & got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=CodonAlphabet(),
rate.list=rate.list,
equ.dist=equ.dist
);
this<-extend(this, "CodonSubst");
}
# Got rate list
else if(got.rate.list & !got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=CodonAlphabet(),
rate.list=rate.list
);
this<-extend.with.s(this);
}
# Got equlibrium distribution,
else if(!got.rate.list & got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=CodonAlphabet(),
equ.dist=equ.dist
);
this<-extend(this, "CodonSubst");
this<-extend.with.s(this);
}
# Got nothing:
else if(!got.rate.list & !got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=CodonAlphabet()
);
this<-extend.with.s(this);
}
}
else {
# PAML file given:
if( got.rate.list){
warning("Building process from PAML file, the \"rate.list\" parameter is ignored!\n");
}
this<-GeneralSubstitution(
name=name,
alphabet=CodonAlphabet()
);
this<-extend.with.s(this);
if(got.equ.dist){
setEquDist(this,equ.dist,force=TRUE);
}
buildFromPAML(this, paml.file);
}
# Force clearing id cache:
this$name<-this$name;
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="CodonSubst",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if(!inherits(this$alphabet, "CodonAlphabet")){
throw("This process must have as alphabet an CodonAlphabet object!\n");
}
if(!any(is.na(this$.s.matrix))){
for(i in this$.alphabet$.symbols){
for(j in this$.alphabet$.symbols){
if(i != j){
expected<-this$.s.matrix[i, j] * this$.equ.dist[1,j];
actual<-this$.q.matrix$.orig.matrix[i,j];
if(!PSRoot$my.all.equal(expected, actual)){
throw("The rate matrix is not compatible with the exchangeability matrix and the equilibrium distribution!\n");
}
}
}
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: buildFromPAML
##
###########################################################################/**
#
# @RdocMethod buildFromPAML
#
# @title "Build rate matrix from PAML file"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonSubst object.}
# \item{paml.file}{Path to the PAML file.}
# \item{...}{Not used.}
# }
#
# \value{
# The CodonSubst object (invisible).
# }
#
# \examples{
# # create an object
# p<-CodonSubst()
# # build rate matrix from paml file
# # buildFromPAML(p,"path_to_paml_file") # do not run this
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"buildFromPAML",
class="CodonSubst",
function(
this,
paml.file,
...
){
if(!missing(paml.file)){
data<-.readFromPAML(this, paml.file=paml.file);
this$.paml.file<-paml.file;
if(all(is.na(this$equDist))){
setEquDist(this, value=data[["pi"]], force=TRUE, silent=TRUE)
}
S<-data$S;
this$.s.matrix<-S;
for(i in this$.alphabet$.symbols){
for(j in this$.alphabet$.symbols){
if(i != j){
setRate(this$.q.matrix,from=i,to=j,value=(S[i,j] * this$.equ.dist[1, j]),scale=FALSE);
}
}
}
.callRateRescaling(this$.q.matrix,guess.equ=FALSE);
}
else{
throw("PAML data file not specified");
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .readFromPAML
##
setMethodS3(
".readFromPAML",
class="CodonSubst",
function(
this,
paml.file,
...
){
if(missing(paml.file)){
throw("No PAML data file specified!\n");
}
else if(file.access(c(paml.file), mode=0) != c(0)){
throw("The specified PAML data file \"",paml.file,"\" does not exist!\n",sep="");
}
else if(file.access(c(paml.file), mode=4) != c(0)){
throw("The specified PAML data file \"",paml.file,"\" cannot be opened for reading because of insufficient permissions!\n",sep="");
}
else {
size<-this$alphabet$size;
symbols<-this$alphabet$symbols;
lines<-scan(file=paml.file,what="character",sep="\n",blank.lines.skip=FALSE,quiet=TRUE);
is.blank<-function(line){
if(length(grep(pattern="^\\s*$",x=line,perl=TRUE,value=FALSE)) > 0 ){
return(TRUE);
}
else if(length(grep(pattern="\\d",x=line,perl=TRUE,value=FALSE)) < 1){
# If the line has no decimal number than is considered blank!
return(TRUE);
}
return(FALSE);
}
# Skip blank lines:
count<-1;
while(is.blank(lines[[count]])){
count<-count+1;
}
skip<-count-1;
# Find the beggining of the equilibrium distribution:
count<-skip+size+1;
while(is.blank(lines[[count]])){
count<-count+1;
}
equ.skip<-count-1;
# How many lines has the equilibrium distribution?
count<-equ.skip;
while(!is.blank(lines[[count<-count+1]])){ }
equ.nlines<-count-equ.skip-1;
# We don't need the lines any more.
rm(lines);
# Reading the exchangeability matrix:
# Assuming here that the order of the
# codons is the same as in the CodonAlphabet
# object.
numbers<-scan(file=paml.file,what=0.0,skip=skip,nlines=(size-1),quiet=TRUE);
if(length(numbers) != ((size^2-size)/2)){
throw("Error reading exchangeability matrix from PAML data file!\n");
}
s.matrix<-matrix(nrow=size,ncol=size);
diag(s.matrix)<-0;
colnames(s.matrix)<-symbols;
rownames(s.matrix)<-symbols;
counter<-1;
for(i in 1:size) {
for(j in 1:i){
if( i!= j){
s.matrix[i, j]<-numbers[counter];
s.matrix[j, i]<-numbers[counter];
counter<-counter + 1;
}
}
}
# Reading the equilibrium distribution:
equ.dist<-(scan(file=paml.file,what=0.0,skip=equ.skip, nlines=equ.nlines, quiet=TRUE));
if(length(equ.dist) != size){
throw("Error reading equlibrium distribution from PAML data file!\n");
}
equ.dist<-rbind(equ.dist);
colnames(equ.dist)<-symbols;
return(list(
"S"=s.matrix,
"pi"=equ.dist
));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setEquDist
##
setMethodS3(
"setEquDist",
class="CodonSubst",
function(
this,
value,
force=FALSE,
silent=FALSE,
...
){
# Behave like GeneralSubstitution if the S matrix is empty.
if(any(is.na(this$.s.matrix))){
return(NextMethod());
}
.checkWriteProtection(this);
if(!is.Alphabet(this$alphabet)){
throw("Cannot set equilibrium distribution because the alphabet is undefined!");
}
if(missing(value)) {
throw("No new value provided!\n");}
else if(!is.numeric(value)) {
throw("The new value must be numeric!\n");
}
else if(length(value) != this$alphabet$size){
throw("The new value must be a vector of length ",this$alphabet$size,"!\n");
}
else if(!PSRoot$my.all.equal(sum(value), 1.0)) {
value<-(value/sum(value));
if (silent == FALSE){
warning("The provided probabilities were rescaled in order to sum to one!\n");
}
}
value<-rbind(value);
colnames(value)<-this$.alphabet$symbols;
this$.equ.dist<-value;
for(i in this$.alphabet$.symbols){
for(j in this$.alphabet$.symbols){
if(i != j){
setRate(this$.q.matrix,from=i,to=j,value=(this$.s.matrix[i,j] * value[1, j]),scale=FALSE);
}
}
}
.callRateRescaling(this$QMatrix,guess.equ=FALSE);
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-CodonSubst()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="CodonSubst",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
.addSummaryAlphabet(this);
if(is.na(this$.paml.file)){
this$.summary$"Unscaled rate matrix"<-paste( "\n\t",paste(capture.output(print(this$.q.matrix$matrix,digits=5)
),collapse="\n\t"),"\n",sep="");
}
else {
this$.summary$"PAML data file:"<-this$.paml.file;
this$.summary$"Unscaled rate matrix"<-"not shown";
}
this$.summary$"Equilibrium distribution"<-paste( "\n\t",paste(capture.output(print(this$.equ.dist)),collapse="\n\t"
),"\n",sep="");
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: newMatrix
##
###########################################################################/**
#
# @RdocMethod newMatrix
#
# @title "New codon substitution matrix from PAML file"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name}
# \item{paml.file}{PAML file.}
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \value{
# A process object inheriting from CodonSubst.
# }
#
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"newMatrix",
class="CodonSubst",
function(
name=NA,
paml.file=NA,
equ.dist=NA,
...
){
PAMLDIR<-"./PAMLdat";
RDATDIR<-"./RData";
# Use the package data directory if loaded:
if(length(intersect(search(),c("package:phylosim"))) == 1){
RDATDIR<-paste(path.package("phylosim"),"/data/",sep="");
PAMLDIR<-paste(path.package("phylosim"),"/extdata/",sep="");
}
rdname<-paste(RDATDIR,"/",name,".RData",sep="");
if( ( file.access(c(rdname), mode=0) == c(0) ) & (file.access(c(rdname), mode=4) == c(0))){
this<-clone(Object$load(rdname));
}
else {
file<-paste(PAMLDIR,"/",paml.file,sep="");
this<-CodonSubst(paml.file=file);
this<-extend(this,name);
this$name<-this$name;
save(this, file=rdname);
}
if(!any(is.na(equ.dist))){
setEquDist(this,value=equ.dist,force=TRUE);
}
return(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass ContinuousDeletor
#
# @title "The ContinuousDeletor class"
#
# \description{
# This class implements a process which performs deletions with
# lengths sampled from a user-specified R expression returning a
# numeric value.
# See \code{GeneralDeletor} for the how the deletion processes
# works.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{rate}{The general rate.}
# \item{dist}{The length sampling expression.}
# \item{max.length}{Maximum event length.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a ContinuousDeletor process
# o<-ContinuousDeletor(
# name="Conty",
# rate=0.25,
# dist=expression(1),
# max.length=2
# )
# # get object summary
# summary(o)
# # set/get length sampling expression
# o$dist<-expression(rnorm(1,mean=3,sd=3))
# o$dist
# # set/get maximum event length
# o$maxLength<-4
# o$maxLength
# # plot length density
# plot(o)
#
# # The following code illustrates how to use
# # a ContinuousDeletor process in a simulation
#
# # create a sequence object, attach process o
# s<-NucleotideSequence(string="AAAAAAAAAAGGGGAAAAAAAAAA",processes=list(list(o)))
# # set the deletion tolerance to zero in range 11:15
# # creating a region rejecting all deletions
# setDeletionTolerance(s,o,0,11:15)
# # get deletion tolerances
# getDeletionTolerance(s,o)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # simulate
# Simulate(sim)
# # print resulting alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GeneralDeletor DiscreteDeletor GeneralInDel
# }
#
#*/###########################################################################
setConstructorS3(
"ContinuousDeletor",
function(
name="Anonymous",
rate=NA,
dist=NA,
max.length=NA,
...
) {
this<-GeneralDeletor(
name=NA,
rate=rate,
propose.by=NA,
accept.by=NA,
...
);
this<-extend(
this,
"ContinuousDeletor",
.dist=NA,
.max.length=NA
);
# Using virtual field to clear Id cache:
this$name<-name;
STATIC<-TRUE;
if(!missing(dist)) {
this$dist<-dist;
STATIC<-FALSE;
}
if(!missing(max.length)) {
this$.max.length<-max.length;
STATIC<-FALSE;
}
this$proposeBy<-function(process=NA,...){
if(!exists(x="PSIM_FAST")){
if(!is.expression(process$.dist)){
throw("\"dist\" is undefined, so cannot propose deletion length!\n");
}
else if(is.na(process$.max.length)){
throw("\"maxLength\" is undefined, so cannot propose deletion length!\n");
}
}
tmp<-round(eval(process$.dist));
while( tmp > process$.max.length | tmp < 1){ tmp<-round(eval(process$.dist)) };
return(tmp);
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="ContinuousDeletor",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if (!is.na(this$maxLength)) {
this$maxLength<-this$maxLength;
}
if (is.expression(this$dist)) {
this$dist<-this$dist;
}
else if (!is.na(this$dist)){
throw("Deletion length sampler expression is invalid!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getDist
##
###########################################################################/**
#
# @RdocMethod getDist
#
# @title "Get the length sampling expression"
#
# \description{
# @get "title".
#
# The length sampling expression can be any valid R expression returning
# a numeric vector of length one. The value returned by the expression will be
# rounded.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ContinuousDeletor object.}
# \item{...}{Not used.}
# }
#
# \value{
# An R expression object.
# }
#
# \examples{
# # create object
# o<-ContinuousDeletor(rate=1)
# # set/get length sampling expression
# setDist(o, expression(rnorm(1,mean=3, sd=2)))
# getDist(o)
# # set/get length sampling expression via virtual field
# o$dist<-expression(rnorm(1,mean=6,sd=3))
# o$dist
# # set maxLength
# o$maxLength<-10
# # propose a length
# proposeLength(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getDist",
class="ContinuousDeletor",
function(
this,
...
){
this$.dist;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setDist
##
###########################################################################/**
#
# @RdocMethod setDist
#
# @title "Set the length sampling expression"
#
# \description{
# @get "title".
#
# The length sampling expression can be any valid R expression returning
# a numeric vector of length one. The value returned by the expression will be
# rounded.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ContinuousDeletor object.}
# \item{value}{An R expression.}
# \item{...}{Not used.}
# }
#
# \value{
# An R expression object.
# }
#
# \examples{
# # create object
# o<-ContinuousDeletor(rate=1)
# # set/get length sampling expression
# setDist(o, expression(rnorm(1,mean=3, sd=2)))
# getDist(o)
# # set/get length sampling expression via virtual field
# o$dist<-expression(rnorm(1,mean=6,sd=3))
# o$dist
# # set maxLength
# o$maxLength<-10
# # propose a length
# proposeLength(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setDist",
class="ContinuousDeletor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if (missing(value)) {
throw("No new value provided!\n");
}
else if (length(value) != 1 ) {
throw("Value vector size should be 1!\n");
}
else if(!is.expression(value)) {
throw("The new value must be a valid expression!\n");
} else {
# Do a test sampling:
tmp<-eval(value);
if( length(tmp) != 1 ) {
throw("The return value of the length sampler expression must be of length 1!\n");
}
if (!is.numeric(tmp)) {
throw("The return value of the length sampler expression must be numeric!\n");
}
else {
this$.dist<-value;
}
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getMaxLength
##
###########################################################################/**
#
# @RdocMethod getMaxLength
#
# @title "Get the maximum length"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ContinuousDeletor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create object
# o<-ContinuousDeletor(rate=1)
# # set length sampling expression via virtual field
# o$dist<-expression(rnorm(1,mean=6,sd=3))
# # set/get maxLength
# setMaxLength(o, 3)
# getMaxLength(o)
# # set/get maxLength via virtual field
# o$maxLength<-10
# o$maxLength
# # propose a length
# proposeLength(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getMaxLength",
class="ContinuousDeletor",
function(
this,
...
){
this$.max.length;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setMaxLength
##
###########################################################################/**
#
# @RdocMethod setMaxLength
#
# @title "Set the maximum length"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ContinuousDeletor object.}
# \item{value}{A numeric (integer) vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new maximum length.
# }
#
# \examples{
# # create object
# o<-ContinuousDeletor(rate=1)
# # set length sampling expression via virtual field
# o$dist<-expression(rnorm(1,mean=6,sd=3))
# # set/get maxLength
# setMaxLength(o, 3)
# getMaxLength(o)
# # set/get maxLength via virtual field
# o$maxLength<-10
# o$maxLength
# # propose a length
# proposeLength(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setMaxLength",
class="ContinuousDeletor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if (missing(value)) {
throw("No new value provided!\n");
}
else if (length(value) != 1 ) {
throw("Value vector size should be 1!\n");
}
else if (!is.numeric(value)) {
throw("Value vector size should be numeric!\n");
}
else if( round(value) != value ) {
throw("maxLength must be integer!\n");
} else {
this$.max.length<-value;
}
return(invisible(this$.max.length));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: plot
##
###########################################################################/**
#
# @RdocMethod plot
#
# @title "Plot the density of proposed lengths"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A ContinuousDeletor object.}
# \item{sample.size}{Number of lengths sampled for the plot.}
# \item{...}{Not used.}
# }
#
# \value{
# The process object (invisible).
# }
#
# \examples{
# # create object
# o<-ContinuousDeletor(rate=1)
# # set length sampling expression via virtual field
# o$dist<-expression(rnorm(1,mean=10,sd=4))
# # set maxLength
# setMaxLength(o, 30)
# # plot density
# plot(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"plot",
class="ContinuousDeletor",
function(
x,
sample.size=NA,
...
){
this<-x;
if( !is.numeric(this$maxLength) | !is.expression(this$dist) ){
warning("Deletion length distribution is not defined properly! Nothing to plot here!\n");
return();
}
size<-(this$maxLength * 10);
if(!missing(sample.size)){
if(!is.numeric(sample.size) | ( length(sample.size)) !=1 ) {
throw("Sample size paramter must be a numeric vector of size 1!\n");
} else {
size<-round(sample.size);
}
}
sample<-apply(as.array(0:size),1,function(...){this$.propose.by(this)});
plot.default(
density(sample,from=0,to=this$maxLength),
main=paste("Estimated deletion size density for:",this$id),
sub=paste("Sample size:", size),
type='l',
xlab="Size",
ylab="Density",
xlim=c(1,this$maxLength),
col="blue",
lwd=1.5,
xaxt="n"
);
axis(side=1, at=c(0:this$maxLength), labels=c(0:this$maxLength));
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-ContinuousDeletor(rate=1,dist=expression(rnorm(1,mean=5,sd=3)), max.length=10)
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="ContinuousDeletor",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
this$.summary$"Length sampling expression"<-deparse(this$dist);
this$.summary$"Maximum deletion length"<-this$maxLength;
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass ContinuousInsertor
#
# @title "The ContinuousInsertor class"
#
# \description{
# This class implements a process which performs insertions with
# lengths sampled from a user-specified R expression returning a
# numeric value.
# See \code{GeneralInsertor} for the how the insertion process
# works.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{rate}{The general rate.}
# \item{dist}{The length sampling expression.}
# \item{max.length}{Maximum event length.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a ContinuousInsertor process
# o<-ContinuousInsertor(
# name="Conty",
# rate=0.1,
# dist=expression(1),
# max.length=2
# )
# # set template sequence
# o$templateSeq<-NucleotideSequence(string="CAC")
# # get object summary
# summary(o)
# # set/get length sampling expression
# o$dist<-expression(rnorm(1,mean=3,sd=3))
# o$dist
# # set/get maximum event length
# o$maxLength<-4
# o$maxLength
# # plot length density
# plot(o)
#
# # The following code illustrates how to use
# # a ContinuousInsertor process in a simulation
#
# # create a sequence object, attach process o
# s<-NucleotideSequence(string="AAAAAAAAAAGGGGAAAAAAAAAA",processes=list(list(o)))
# # set the insertion tolerance to zero in range 11:15
# # creating a region rejecting all insertions
# setInsertionTolerance(s,o,0,11:15)
# # get insertion tolerances
# getInsertionTolerance(s,o)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # simulate
# Simulate(sim)
# # print resulting alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GeneralInsertor DiscreteInsertor GeneralInDel
# }
#
#*/###########################################################################
setConstructorS3(
"ContinuousInsertor",
function(
name="Anonymous",
rate=NA,
dist=NA,
max.length=NA,
...
) {
this<-GeneralInsertor(
name=NA,
rate=rate,
propose.by=NA,
accept.by=NA,
...
);
this<-extend(
this,
"ContinuousInsertor",
.dist=NA,
.max.length=NA
);
# Using virtual field to clear Id cache:
this$name<-name;
STATIC<-TRUE;
if(!missing(dist)) {
this$dist<-dist;
STATIC<-FALSE;
}
if(!missing(max.length)) {
this$.max.length<-max.length;
STATIC<-FALSE;
}
this$proposeBy<-function(process=NA,...){
if(!exists(x="PSIM_FAST")){
if(!is.expression(process$.dist)){
throw("\"dist\" is undefined, so cannot propose insertion length!\n");
}
else if(is.na(process$.max.length)){
throw("\"maxLength\" is undefined, so cannot propose insertion length!\n");
}
}
tmp<-round(eval(process$.dist));
while( tmp > process$.max.length | tmp < 1){ tmp<-round(eval(process$.dist)) };
return(tmp);
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="ContinuousInsertor",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if (!is.na(this$maxLength)) {
this$maxLength<-this$maxLength;
}
if (is.expression(this$dist)) {
this$dist<-this$dist;
}
else if (!is.na(this$dist)){
throw("Insertion length sampler expression is invalid!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getDist
##
###########################################################################/**
#
# @RdocMethod getDist
#
# @title "Get the length sampling expression"
#
# \description{
# @get "title".
#
# The length sampling expression can be any valid R expression returning
# a numeric vector of length one. The value returned by the expression will be
# rounded.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ContinuousInsertor object.}
# \item{...}{Not used.}
# }
#
# \value{
# An R expression object.
# }
#
# \examples{
# # create object
# o<-ContinuousInsertor(rate=1)
# # set/get length sampling expression
# setDist(o, expression(rnorm(1,mean=3, sd=2)))
# getDist(o)
# # set/get length sampling expression via virtual field
# o$dist<-expression(rnorm(1,mean=6,sd=3))
# o$dist
# # set maxLength
# o$maxLength<-10
# # propose a length
# proposeLength(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getDist",
class="ContinuousInsertor",
function(
this,
...
){
this$.dist;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setDist
##
###########################################################################/**
#
# @RdocMethod setDist
#
# @title "Set the length sampling expression"
#
# \description{
# @get "title".
#
# The length sampling expression can be any valid R expression returning
# a numeric vector of length one. The value returned by the expression will be
# rounded.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ContinuousInsertor object.}
# \item{value}{An R expression.}
# \item{...}{Not used.}
# }
#
# \value{
# An R expression object.
# }
#
# \examples{
# # create object
# o<-ContinuousInsertor(rate=1)
# # set/get length sampling expression
# setDist(o, expression(rnorm(1,mean=3, sd=2)))
# getDist(o)
# # set/get length sampling expression via virtual field
# o$dist<-expression(rnorm(1,mean=6,sd=3))
# o$dist
# # set maxLength
# o$maxLength<-10
# # propose a length
# proposeLength(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setDist",
class="ContinuousInsertor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if (missing(value)) {
throw("No new value provided!\n");
}
else if (length(value) != 1 ) {
throw("Value vector size should be 1!\n");
}
else if(!is.expression(value)) {
throw("The new value must be a valid expression!\n");
} else {
# Do a test sampling:
tmp<-eval(value);
if( length(tmp) != 1 ) {
throw("The return value of the length sampler expression must be of length 1!\n");
}
if (!is.numeric(tmp)) {
throw("The return value of the length sampler expression must be numeric!\n");
}
else {
this$.dist<-value;
}
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getMaxLength
##
###########################################################################/**
#
# @RdocMethod getMaxLength
#
# @title "Get the maximum length"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ContinuousInsertor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create object
# o<-ContinuousInsertor(rate=1)
# # set length sampling expression via virtual field
# o$dist<-expression(rnorm(1,mean=6,sd=3))
# # set/get maxLength
# setMaxLength(o, 3)
# getMaxLength(o)
# # set/get maxLength via virtual field
# o$maxLength<-10
# o$maxLength
# # propose a length
# proposeLength(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getMaxLength",
class="ContinuousInsertor",
function(
this,
...
){
this$.max.length;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setMaxLength
##
###########################################################################/**
#
# @RdocMethod setMaxLength
#
# @title "Set the maximum length"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ContinuousInsertor object.}
# \item{value}{A numeric (integer) vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new maximum length.
# }
#
# \examples{
# # create object
# o<-ContinuousInsertor(rate=1)
# # set length sampling expression via virtual field
# o$dist<-expression(rnorm(1,mean=6,sd=3))
# # set/get maxLength
# setMaxLength(o, 3)
# getMaxLength(o)
# # set/get maxLength via virtual field
# o$maxLength<-10
# o$maxLength
# # propose a length
# proposeLength(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setMaxLength",
class="ContinuousInsertor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if (missing(value)) {
throw("No new value provided!\n");
}
else if (length(value) != 1 ) {
throw("Value vector size should be 1!\n");
}
else if (!is.numeric(value)) {
throw("Value vector size should be numeric!\n");
}
else if( round(value) != value ) {
throw("maxLength must be integer!\n");
} else {
this$.max.length<-value;
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: plot
##
###########################################################################/**
#
# @RdocMethod plot
#
# @title "Plot the density of proposed lengths"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A ContinuousInsertor object.}
# \item{sample.size}{Number of lengths sampled for the plot.}
# \item{...}{Not used.}
# }
#
# \value{
# The process object (invisible).
# }
#
# \examples{
# # create object
# o<-ContinuousInsertor(rate=1)
# # set length sampling expression via virtual field
# o$dist<-expression(rnorm(1,mean=10,sd=4))
# # set maxLength
# setMaxLength(o, 30)
# # plot density
# plot(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"plot",
class="ContinuousInsertor",
function(
x,
sample.size=NA,
...
){
this<-x;
if( !is.numeric(this$maxLength) | !is.expression(this$dist) ){
warning("Insertion length distribution is not defined properly! Nothing to plot here!\n");
return();
}
size<-(this$maxLength * 10);
if(!missing(sample.size)){
if(!is.numeric(sample.size) | ( length(sample.size)) !=1 ) {
throw("Sample size paramter must be a numeric vector of size 1!\n");
} else {
size<-round(sample.size);
}
}
sample<-apply(as.array(0:size),1,function(...){this$.propose.by(this)});
plot.default(
density(sample,from=0,to=this$maxLength),
main=paste("Estimated insertion size density for:",this$id),
sub=paste("Sample size:", size),
type='l',
xlab="Size",
ylab="Density",
col="red",
lwd=1.5,
xaxt="n"
);
axis(side=1, at=(0:this$maxLength), labels=(0:this$maxLength));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-ContinuousInsertor(rate=1,dist=expression(rnorm(1,mean=5,sd=2)),max.length=7)
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="ContinuousInsertor",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
this$.summary$"Length sampling expression"<-deparse(this$dist);
this$.summary$"Maximum insertion length"<-this$maxLength;
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass DiscreteDeletor
#
# @title "The DiscreteDeletor class"
#
# \description{
# This class implements a process which performs deletions with
# lengths sampled from a user-specified discrete distribution.
# See \code{GeneralDeletor} for how the deletion process works.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{rate}{The general rate.}
# \item{sizes}{The deletion sizes to propose.}
# \item{probs}{A vector with the probabilites of the deletion sizes.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a DiscreteDeletor process
# d<-DiscreteDeletor(
# name="M.D.",
# rate=0.25,
# sizes=c(1,2),
# probs=c(1/2,1/2)
# )
# # get object summary
# summary(d)
# # set/get deletions sizes
# d$sizes<-1:3
# d$sizes
# # set/get length probabilities
# d$probs<-c(3,2,1)/6
# d$probs
# # plot length distribution
# plot(d)
#
# # The following code illustrates how to use
# # a DiscreteDeletor process in a simulation
#
# # create a sequence object, attach process d
# s<-NucleotideSequence(string="AAAAAAAAAAGGGGAAAAAAAAAA",processes=list(list(d)))
# # set the deletion tolerance to zero in the range 11:15
# # creating a region rejecting all deletions
# setDeletionTolerance(s,d,0,11:15)
# # get deletion tolerances
# getDeletionTolerance(s,d)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # simulate
# Simulate(sim)
# # print resulting alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GeneralDeletor ContinuousDeletor GeneralInDel
# }
#
#*/###########################################################################
setConstructorS3(
"DiscreteDeletor",
function(
name="Anonymous",
rate=NA,
sizes=NA,
probs=NA,
...
) {
this<-GeneralDeletor(
name=NA,
rate=rate,
propose.by=NA,
accept.by=NA,
...
);
this<-extend(
this,
"DiscreteDeletor",
.sizes=NA,
.probs=NA
);
# Using virtual field to clear Id cache:
this$name<-name;
STATIC<-TRUE;
if(!missing(sizes)) {
this$sizes<-sizes;
STATIC<-FALSE;
}
if(!missing(probs)) {
this$probs<-probs;
STATIC<-FALSE;
}
this$proposeBy<-function(process=NA,...){
if(!exists(x="PSIM_FAST")){
if( !is.numeric(process$.sizes) | !is.numeric(process$.probs) ){
throw("Cannot propose deletion length because the length distribution is not defined properly!\n");
}
}
if(length(process$.sizes) == 1){
return(process$.sizes[[1]]);
} else {
return(sample(x=process$.sizes,size=1,replace=FALSE,prob=process$.probs));
}
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="DiscreteDeletor",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if (is.numeric(this$sizes)) {
this$sizes<-this$sizes;
}
else if (!is.na(this$sizes)){
throw("Deletion size vector is invalid!\n");
}
if (is.numeric(this$probs)) {
this$probs<-this$probs;
}
else if (!is.na(this$probs)){
throw("Deletion size probability vector is invalid!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSizes
##
###########################################################################/**
#
# @RdocMethod getSizes
#
# @title "Get the sizes of the proposed deletions"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A DiscreteDeletor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A vector of integers.
# }
#
# \examples{
# # create a DiscreteDeletor object
# d<-DiscreteDeletor(rate=1)
# # set deletion sizes
# setSizes(d,c(1,2,3))
# # get deletion sizes
# getSizes(d)
# # set/get sizes via virtual field
# d$sizes<-1:10
# d$sizes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSizes",
class="DiscreteDeletor",
function(
this,
...
){
this$.sizes;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setSizes
##
###########################################################################/**
#
# @RdocMethod setSizes
#
# @title "Set the sizes of the proposed deletions"
#
# \description{
# @get "title".
#
# The provided numeric vector is rounded.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A DiscreteDeletor object.}
# \item{value}{A numeric vector.}
# \item{...}{Not used.}
# }
#
# \value{
# A vector of integers (invisible).
# }
#
# \examples{
# # create a DiscreteDeletor object
# d<-DiscreteDeletor(rate=1)
# # set deletion sizes
# setSizes(d,c(1,2,3))
# # get deletion sizes
# getSizes(d)
# # set/get sizes via virtual field
# d$sizes<-1:10
# d$sizes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setSizes",
class="DiscreteDeletor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if (missing(value)) {
throw("No new value provided!\n");
} else if (!is.numeric(value)) {
throw("The new value must be numeric vector!\n");
} else {
if(length(value) == 0 ) {
warning("Deletion size vector has zero length!\n");
}
this$.sizes<-round(value);
}
return(invisible(this$.sizes));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getProbs
##
###########################################################################/**
#
# @RdocMethod getProbs
#
# @title "Get the deletion length probabilities"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A DiscreteDeletor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector with the deletion length probabilities.
# }
#
# \examples{
# # create a DiscreteDeletor object
# d<-DiscreteDeletor(rate=1, sizes=1:3)
# # set/get length probabilities
# setProbs(d,c(1/3,1/3,1/3)) # equal probabilites
# getProbs(d)
# # set/get length probabilities via virtual field
# x<-c(2,2,1)
# # normalize x
# x<-x/sum(x)
# d$probs<-x
# d$probs
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getProbs",
class="DiscreteDeletor",
function(
this,
...
){
this$.probs;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setProbs
##
###########################################################################/**
#
# @RdocMethod setProbs
#
# @title "Set the deletion length probabilities"
#
# \description{
# @get "title".
#
# The \code{sizes} virtual field must be set before setting the length probabilities.
# The length of the provided numeric vector must match with the length of the vector
# stored in the \code{sizes} virtual field. The vector is rescaled if the values do not
# sum to one and a warning is issued.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A DiscreteDeletor object.}
# \item{value}{A numeric vector containg the length probabilities.}
# \item{...}{Not used.}
# }
#
# \value{
# The vector of probabilities.
# }
#
# \examples{
# # create a DiscreteDeletor object
# d<-DiscreteDeletor(rate=1, sizes=1:3)
# # set/get length probabilities
# setProbs(d,c(1/3,1/3,1/3)) # equal probabilites
# getProbs(d)
# # set/get length probabilities via virtual field
# x<-c(2,2,1)
# # normalize x
# x<-x/sum(x)
# d$probs<-x
# d$probs
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setProbs",
class="DiscreteDeletor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if (missing(value)) {
throw("No new value provided!\n");
}
else if(!is.numeric(this$.sizes)) {
throw("Cannot set probabilities because indel size vector is not defined!\n");
}
else if (!is.numeric(value)) {
throw("The new value must be a numeric vector!\n");
}
else if(length(value) != length(this$.sizes)) {
throw("The length of the probabilities vector must be the same as the length of the deletion sizes vector");
}
else if( length(value[value < 0 ]) != 0 ) {
throw("The elements of the probability vector must not be negative!\n");
}
else {
if(!isTRUE(all.equal(sum(value),1.0))){
value<-value/sum(value);
warning("The provided values were rescaled in order to sum to one!\n");
}
this$.probs<-value;
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
# # create an object
# a<-DiscreteDeletor(rate=1,sizes=c(1,2),probs=c(1/2,1/2))
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="DiscreteDeletor",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
expected.length<-NA;
sd<-NA;
if( is.numeric(this$sizes) & is.numeric(this$probs)) {
expected.length<-weighted.mean(this$sizes, this$probs);
sd<-sqrt(sum( (this$sizes - expected.length)^2 * this$probs ));
}
this$.summary$"Expected deletion length"<-expected.length;
this$.summary$"Standard deviation of deletion length"<-format(sd);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: plot
##
###########################################################################/**
#
# @RdocMethod plot
#
# @title "Plot the deletion length distribution"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A DiscreteDeletor object.}
# \item{...}{Not used.}
# }
#
# \value{
# The DiscreteDeletor object (invisible).
# }
#
# \examples{
# d<-DiscreteDeletor(
# name="MyDiscDel",
# sizes=1:6,
# probs=c(0.25000000, 0.16666667, 0.08333333, 0.08333333, 0.16666667, 0.25000000)
# )
# # plot the deletion length distribution
# plot(d)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"plot",
class="DiscreteDeletor",
function(
x,
...
){
this<-x;
if( !is.numeric(this$sizes) | !is.numeric(this$probs) ){
warning("Deletion length distribution is not defined properly! Nothing to plot here!\n");
return();
}
plot.default(
x=this$sizes,
y=this$probs,
col=c("blue"),
lwd=2,
type="h",
main=paste("Deletion size distribution for:",this$id),
xlab="Size",
ylab="Probability",
ylim=c(0,1),
xaxt="n"
);
axis(side=1, at=this$sizes, labels=this$sizes);
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass DiscreteInsertor
#
# @title "The DiscreteInsertor class"
#
# \description{
# This class implements a process which performs insertions with
# lengths sampled from a user-specified discrete distribution.
# See \code{GeneralInsertor} for how the insertion process works.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{rate}{The general rate.}
# \item{sizes}{The insertion sizes to propose.}
# \item{probs}{A vector with the probabilites of the insertion sizes.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a DiscreteInsertor process
# i<-DiscreteInsertor(
# name="Mii",
# rate=0.25,
# sizes=c(1,2),
# probs=c(1/2,1/2)
# )
# # set template sequence
# i$templateSeq<-NucleotideSequence(string="C")
# # get object summary
# summary(i)
# # set/get insertion sizes
# i$sizes<-1:3
# i$sizes
# # set/get length probabilities
# i$probs<-c(3,2,1)/6
# i$probs
# # plot length distribution
# plot(i)
#
# # The following code illustrates how to use
# # a DiscreteInsertor process in a simulation
#
# # create a sequence object and attach process i to it
# s<-NucleotideSequence(string="AAAAAAAAAAGGGGAAAAAAAAAA",processes=list(list(i)))
# # set the insertion tolerance to zero in range 11:15
# # creating a region rejecting all insertions
# setInsertionTolerance(s,i,0,11:15)
# # get insertion tolerances
# getInsertionTolerance(s,i)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # simulate
# Simulate(sim)
# # print resulting alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GeneralInsertor ContinuousInsertor GeneralInDel
# }
#
#*/###########################################################################
setConstructorS3(
"DiscreteInsertor",
function(
name="Anonymous",
rate=NA,
sizes=NA,
probs=NA,
...
) {
this<-GeneralInsertor(
name=NA,
rate=rate,
propose.by=NA,
accept.by=NA,
generate.by=NA,
...
);
this<-extend(
this,
"DiscreteInsertor",
.sizes=NA,
.probs=NA
);
# Using virtual field to clear Id cache:
this$name<-name;
STATIC<-TRUE;
if(!missing(sizes)) {
this$sizes<-sizes;
STATIC<-FALSE;
}
if(!missing(probs)) {
this$probs<-probs;
STATIC<-FALSE;
}
this$proposeBy<-function(process=NA,...){
if( !is.numeric(process$.sizes) | !is.numeric(process$.probs) ){
throw("Cannot propose insert length because the length distribution is not defined properly!\n");
}
if(length(process$.sizes) == 1){
return(process$.sizes[[1]]);
} else {
return(sample(x=process$.sizes,size=1,replace=FALSE,prob=process$.probs));
}
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="DiscreteInsertor",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if (is.numeric(this$sizes)) {
this$sizes<-this$sizes;
}
else if (!is.na(this$sizes)){
throw("Insertion size vector is invalid!\n");
}
if (is.numeric(this$probs)) {
this$probs<-this$probs;
}
else if (!is.na(this$probs)){
throw("Insertion size probability vector is invalid!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSizes
##
###########################################################################/**
#
# @RdocMethod getSizes
#
# @title "Get the sizes of the proposed insertions"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A DiscreteInsertor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A vector of integers.
# }
#
# \examples{
# # create a DiscreteInsertor object
# i<-DiscreteInsertor(rate=1)
# # set insertion sizes
# setSizes(i,c(1,2,3))
# # get insertion sizes
# getSizes(i)
# # set/get sizes via virtual field
# i$sizes<-1:10
# i$sizes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSizes",
class="DiscreteInsertor",
function(
this,
...
){
this$.sizes;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setSizes
##
###########################################################################/**
#
# @RdocMethod setSizes
#
# @title "Set the sizes of the proposed insertions"
#
# \description{
# @get "title".
#
# The provided numeric vector is rounded.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A DiscreteInsertor object.}
# \item{value}{A numeric vector.}
# \item{...}{Not used.}
# }
#
# \value{
# A vector of integers (invisible).
# }
#
# \examples{
# # create a DiscreteInsertor object
# i<-DiscreteInsertor(rate=1)
# # set insertion sizes
# setSizes(i,c(1,2,3))
# # get insertion sizes
# getSizes(i)
# # set/get sizes via virtual field
# i$sizes<-1:10
# i$sizes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setSizes",
class="DiscreteInsertor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if (missing(value)) {
throw("No new value provided!\n");
} else if (!is.numeric(value)) {
throw("The new value must be numeric vector!\n");
} else {
if(length(value) == 0 ) {
warning("Deletion size vector has zero length!\n");
}
this$.sizes<-round(value);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getProbs
##
###########################################################################/**
#
# @RdocMethod getProbs
#
# @title "Get the insertion length probabilities"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A DiscreteInsertor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector with the insertion length probabilities.
# }
#
# \examples{
# # create a DiscreteInsertor object
# i<-DiscreteInsertor(rate=1, sizes=1:3)
# # set/get length probabilities
# setProbs(i,c(1/3,1/3,1/3)) # equal probabilites
# getProbs(i)
# # set/get length probabilities via virtual field
# x<-c(2,2,1)
# # normalize x
# x<-x/sum(x)
# i$probs<-x
# i$probs
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getProbs",
class="DiscreteInsertor",
function(
this,
...
){
this$.probs;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setProbs
##
###########################################################################/**
#
# @RdocMethod setProbs
#
# @title "Set the insertion length probabilities"
#
# \description{
# @get "title".
#
# The \code{sizes} virtual field must be set before setting the length probabilities.
# The length of the provided numeric vector must match with the length of the vector
# stored in the \code{sizes} virtual field. The vector is rescaled if the values do not
# sum to one and a warning is issued.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A DiscreteInsertor object.}
# \item{value}{A numeric vector containg the length probabilities.}
# \item{...}{Not used.}
# }
#
# \value{
# The vector of probabilities.
# }
#
# \examples{
# # create a DiscreteInsertor object
# i<-DiscreteInsertor(rate=1, sizes=1:3)
# # set/get length probabilities
# setProbs(i,c(1/3,1/3,1/3)) # equal probabilites
# getProbs(i)
# # set/get length probabilities via virtual field
# x<-c(2,2,1)
# # normalize x
# x<-x/sum(x)
# i$probs<-x
# i$probs
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setProbs",
class="DiscreteInsertor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if (missing(value)) {
throw("No new value provided!\n");
}
else if(!is.numeric(this$.sizes)) {
throw("Cannot set probabilities because insert sizes vector is not defined!\n");
}
else if (!is.numeric(value)) {
throw("The new value must be a numeric vector!\n");
}
else if(length(value) != length(this$.sizes)) {
throw("The length of the probabilities vector must be the same as the length of the insertion sizes vector");
}
else if( length(value[value < 0 ]) != 0 ) {
throw("The elements of the probability vector must not be negative!\n");
}
else {
if(!isTRUE(all.equal(sum(value),1.0))){
value<-(value/sum(value));
warning("The provided values were rescaled in order to sum to one!\n");
}
this$.probs<-value;
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: plot
##
###########################################################################/**
#
# @RdocMethod plot
#
# @title "Plot the insertion length distribution"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A DiscreteInsertor object.}
# \item{...}{Not used.}
# }
#
# \value{
# The DiscreteInsertor object (invisible).
# }
#
# \examples{
# i<-DiscreteInsertor(
# name="MyDiscIns",
# sizes=1:6,
# probs=c(0.25000000, 0.16666667, 0.08333333, 0.08333333, 0.16666667, 0.25000000)
# )
# # plot the insertion length distribution
# plot(i)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"plot",
class="DiscreteInsertor",
function(
x,
...
){
this<-x;
if( !is.numeric(this$sizes) | !is.numeric(this$probs) ){
warning("Insertion length distribution is not defined properly! Nothing to plot here!\n");
return();
}
plot.default(
x=this$sizes,
y=this$probs,
col=c("red"),
lwd=2,
type="h",
main=paste("Insertion size distribution for:",this$id),
xlab="Size",
ylab="Probability",
ylim=c(0,1),
xaxt="n"
);
axis(side=1, at=this$sizes, labels=this$sizes);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-DiscreteInsertor(rate=1,sizes=c(1,2),probs=c(1/2,1/2))
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="DiscreteInsertor",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
expected.length<-NA;
sd<-NA;
if( is.numeric(this$sizes) & is.numeric(this$probs)) {
expected.length<-weighted.mean(this$sizes, this$probs);
sd<-sqrt(sum( (this$sizes - expected.length)^2 * this$probs ));
}
this$.summary$"Expected insertion length"<-expected.length;
this$.summary$"Standard deviation of insertion length"<-format(sd);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
## ECMrest
##
##########################################################################/**
#
# @RdocClass ECMrest
#
# @title "The ECMrest empirical codon substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Kosiol C., Holmes I., Goldman, N. (2007) An empirical codon model for protein sequence evolution -
# Mol Biol Evol. 24(7):1464-79 DOI: 10.1093/molbev/msm064 \url{http://bit.ly/1ia8gWm}
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-ECMrest()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-CodonSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# CodonSubst GeneralSubstitution CodonUNREST
# }
#
#*/###########################################################################
setConstructorS3(
"ECMrest",
function(
equ.dist=NA,
...
){
this<-CodonSubst$newMatrix(
name="ECMrest",
paml.file="ECMrest.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## ECMunrest
##
##########################################################################/**
#
# @RdocClass ECMunrest
#
# @title "The ECMunrest empirical codon substitution model"
#
# \description{
#
#
# @classhierarchy
# }
#
# \references{
# Kosiol C., Holmes I., Goldman, N. (2007) An empirical codon model for protein sequence evolution -
# Mol Biol Evol. 24(7):1464-79 DOI: 10.1093/molbev/msm064 \url{http://bit.ly/1ia8gWm}
# }
#
# @synopsis
#
# \arguments{
# \item{equ.dist}{Equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution model object
# p<-ECMunrest()
# # get object summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-CodonSequence(length=10,processes=list(list(p)) )
# # sample states
# sampleStates(s)
# # make the first three positions invariable
# setRateMultipliers(s,p,0,1:3)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# CodonSubst GeneralSubstitution CodonUNREST
# }
#
#*/###########################################################################
setConstructorS3(
"ECMunrest",
function(
equ.dist=NA,
...
){
this<-CodonSubst$newMatrix(
name="ECMunrest",
paml.file="ECMunrest.dat",
equ.dist=equ.dist
);
return(this);
},
enforceRCC=FALSE
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass Event
#
# @title "The Event class"
#
# \description{
#
# This is the class representing an event. Event objects usually are generated by the \code{getEventsAtSite.*}
# methods based on the state of attached Site object and the properties of the generating Process object.
#
# The Perform method will refuse to modify target objects if the position field is not set. The Perform method can
# be called only once for any Event object.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the Event object. Often stores useful information.}
# \item{rate}{The rate of the event.}
# \item{site}{The associated Site object.}
# \item{position}{The position of associated Site object in the enclosing Sequence object (if any).}
# \item{process}{The generator Process object.}
# \item{handler}{The handler function for the Event object. It will be called by \code{Perform.Event} with the Event object as an argument to make the changes corresponding to the event.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # Note: the following examples are not very useful
# # unless you want to implement your own process.
#
# # create a Sequence object and a Process object
# seq<-NucleotideSequence(string="A");
# p<-Process(alphabet=NucleotideAlphabet())
# # get the Site object from the Sequence object
# s<-seq$sites[[1]]
# # attach p to s
# attachProcess(s,p)
# # create an Event object
# e<-Event(name="A->G",rate=0.1,site=s,process=p,position=1)
# # get object summary
# summary(e)
# # get event name
# e$name
# # set/get event rate
# e$rate<-0.2
# e$rate
# # get site
# e$site
# # set/get event handler
# e$.handler<-function(this){this$.site$state<-"G"}
# e$handler
# # perform the event
# Perform(e)
# # check the state of the target site
# s$state
# }
#
# @author
#
# \seealso{
# Site Process Sequence getEventsAtSite.GeneralSubstitution
# }
#
#*/###########################################################################
setConstructorS3(
"Event",
function(
name=NA,
rate=NA,
site=NA,
position=NA,
process=NA,
handler=NA,
...
){
this<-extend(
PSRoot(),
"Event",
.name="Anonymous",
.rate=NA,
.process=NA,
.handler=NA,
.site=NA,
.position=NA,
.write.protected=FALSE,
.is.event=TRUE
);
STATIC<-TRUE;
if(!missing(name)) {
this$name<-name;
STATIC<-FALSE;
}
if(!missing(rate)) {
this$rate<-rate;
STATIC<-FALSE;
}
if(!missing(process)) {
this$process<-process;
STATIC<-FALSE;
}
if(!missing(site)) {
this$site<-site;
STATIC<-FALSE;
}
if(!missing(position)) {
this$position<-position;
STATIC<-FALSE;
}
# The site object was passed through a getField method,
# which disabled the virtual fields, so we have to enable them:
if (!is.na(this$.site)){
this$.site<-enableVirtual(this$.site);
}
this;
},
enforceRCC=TRUE
);
##
## Method: is.Event
##
###########################################################################/**
#
# @RdocDefault is.Event
#
# @title "Check whether an object inherits from the class Event"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create some objects
# e<-Event(); a<-Alphabet()
# # check if they inherit from Event
# is.Event(e)
# is.Event(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"is.Event",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.event)){return(TRUE)}
if ( inherits(this, "Event")) {
this$.is.event<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getName
##
###########################################################################/**
#
# @RdocMethod getName
#
# @title "Get the name of an Event object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An event object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create an Event object
# e<-Event(name="MyEvent")
# # get event name
# getName(e)
# # get name via virtual field
# e$name
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getName",
class="Event",
function(
this,
...
){
this$.name;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setName
##
###########################################################################/**
#
# @RdocMethod setName
#
# @title "Set the name of an Event object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Event object.}
# \item{new.name}{A character vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new name (invisible).
# }
#
# \examples{
# # create an Event object
# e<-Event()
# # set event name
# setName(e,"Insertion")
# # get event name
# e$name
# # set name via virtual field
# e$name<-"Deletion"
# e$name
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setName",
class="Event",
function(
this,
new.name,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(new.name)){throw("No new name provided!\n")}
new.name<-as.character(new.name);
if (new.name == "") {throw("Cannot set empty name!\n")}
}
this$.name<-new.name;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRate
##
###########################################################################/**
#
# @RdocMethod getRate
#
# @title "Get the rate of an Event object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Event object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create an Event object
# e<-Event(rate=0.1)
# # get rate
# getRate(e)
# # get rate via virtual field
# e$rate
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRate",
class="Event",
function(
this,
...
){
this$.rate;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRate
##
###########################################################################/**
#
# @RdocMethod setRate
#
# @title "Set the rate of an Event object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Event object.}
# \item{value}{The event rate.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of the rate (invisible).
# }
#
# \examples{
# # create an Event object
# e<-Event(rate=0.1)
# # set a new rate
# setRate(e,0.2)
# # get rate via virtual field
# e$rate
# # set rate via virtual field
# e$rate<-0.5
# e$rate
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRate",
class="Event",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)){throw("No new rate provided!\n")}
else if (!is.numeric(value)){throw("The rate must be numeric!\n")}
}
this$.rate<-value;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getProcess
##
###########################################################################/**
#
# @RdocMethod getProcess
#
# @title "Get the Process object which generated an Event object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Event object.}
# \item{...}{Not used.}
# }
#
# \value{
# A Process object.
# }
#
# \examples{
# # create a sequence and attach a process
# s<-NucleotideSequence(string="ATGC",processes=list(list(JC69())))
# # get the first active event from the first site
# e<-s$sites[[1]]$events[[1]]
# # get the generator process for e
# e$process
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getProcess",
class="Event",
function(
this,
...
){
this$.process;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setProcess
##
###########################################################################/**
#
# @RdocMethod setProcess
#
# @title "Set the generator process for an Event object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Event object.}
# \item{new.proc}{A valid Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# A Process object.
# }
#
# \examples{
# # create an Event object
# e<-Event()
# # set a generator process for e
# setProcess(e,Process())
# # get generator process
# e$process
# # set process via virtual field
# e$process<-K80()
# e$process
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setProcess",
class="Event",
function(
this,
new.proc,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(new.proc)){throw("No new rate provided!\n")}
else if (!is.Process(new.proc)){throw("Process object invalid!\n")}
}
this$.process<-new.proc;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getHandler
##
###########################################################################/**
#
# @RdocMethod getHandler
#
# @title "Get the handler function of an Event object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Event object.}
# \item{...}{Not used.}
# }
#
# \value{
# A function object.
# }
#
# \examples{
# # create a sequence and attach a process
# s<-NucleotideSequence(string="ATGC",processes=list(list(JC69())))
# # get the first active event from the first site
# # only Sequence methods set .position,
# # so s$sites[[1]]$events[[1]] wouldn't work.
# e<-getEvents(s,1)[[1]]
# # het the handler of e
# getHandler(e)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getHandler",
class="Event",
function(
this,
...
){
this$.handler;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setHandler
##
###########################################################################/**
#
# @RdocMethod setHandler
#
# @title "Forbidden action: setting the handler function of an Event object"
#
# \description{
# @get "title".
# The handler function is tipically set by a \code{getEventsAtSite.*} method generating the Event object
# by directly modifying the this$.handler field or by the \code{.setHandler()} method.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setHandler",
class="Event",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSite
##
###########################################################################/**
#
# @RdocMethod getSite
#
# @title "Get the Site object associated with an Event object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Event object.}
# \item{...}{Not used.}
# }
#
# \value{
# A Site object.
# }
#
# \examples{
# # create a sequence and attach a process
# s<-NucleotideSequence(string="ATGC",processes=list(list(JC69())))
# # get the first active event from the first site
# e<-s$sites[[1]]$events[[1]]
# # get the site associated with e
# getSite(e)
# # get site via virtual field
# e$site
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSite",
class="Event",
function(
this,
...
){
this$.site;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getPosition
##
###########################################################################/**
#
# @RdocMethod getPosition
#
# @title "Get the position of the Site object associated to an Event object in the enclosing Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Event object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a sequence and attach a process
# s<-NucleotideSequence(string="ATGC",processes=list(list(JC69())))
# # get the first active event from the first site
# e<-getEvents(s,1)[[1]]
# # get the position of the site associated with e
# getPosition(e)
# # get position via virtual field
# e$position
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getPosition",
class="Event",
function(
this,
...
){
this$.position;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setPosition A function object.
##
###########################################################################/**
#
# @RdocMethod setPosition
#
# @title "Set the position of the Site object associated to an Event object"
#
# \description{
# @get "title".
#
# The position field is usually not modified directly, but set by the \code{getEvents.Sequence} method.
# The position is *not* set by Site methods as \code{getEventsAtSite.Site}.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Event object.}
# \item{value}{The position.}
# \item{...}{Not used.}
# }
#
# \value{
# The new position (invisible).
# }
#
# \examples{
# # Note: the following example is not too useful
#
# # create a sequence and attach a process
# s<-NucleotideSequence(string="ATGC",processes=list(list(JC69())))
# # get the first active event from the first site
# e<-getEvents(s,1)[[1]]
# # get event position
# e$position
# # set the position of the site associated with e
# setPosition(e,2)
# # get position via virtual field
# e$position
# # set position via virtual field
# e$position<-1
# e$position
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setPosition",
class="Event",
function(
this,
value,
...
){
if(!exists(x="PSIM_FAST")){
if(is.na(this$.site)){
throw("There is no associated Site object!\n");
}
if(is.na(this$.site$.sequence)){
throw("The site is not part of any sequence!\n");
}
if(value > this$.site$.sequence$.length | value < 1) {
throw("Invalid position!\n");
}
}
this$.position<-value;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setSite
##
###########################################################################/**
#
# @RdocMethod setSite
#
# @title "Assotiate an Event object with a Site object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Event object.}
# \item{new.site}{A valid Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# The new associated Site object (invisible).
# }
#
# \examples{
# # create an Event object
# e<-Event()
# # create some Site objects
# s1<-Site(alphabet=NucleotideAlphabet(),state="A")
# s2<-clone(s1); s2$state<-"T"
# # assotiate s1 with e
# setSite(e,s1)
# e$site
# # assotiate s2 with e via virtual field
# e$site<-s2
# e$site
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setSite",
class="Event",
function(
this,
new.site,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if (!is.Site(new.site)) {throw("Site object invalid!\n")}
new.site<-enableVirtual(new.site);
if(missing(new.site)) {throw("No site given")}
else if (!is.na(this$process)){
if (this$.process$.alphabet != new.site$.alphabet){
throw("The site and process alphabets are incompatible!\n");
}
}
}
this$.site<-new.site;
invisible(this$.site)
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: Perform
##
###########################################################################/**
#
# @RdocMethod Perform
#
# @title "Perform an event"
#
# \description{
#
# Performing an event means that the modifications described by the Event object are actually made by calling
# the event handler function as returned by \code{getHandler} with the Event object as the first argument.
#
# The event won't be performed if the handler function is invalid, if there is no associated Site object,
# if the site position is undefined, if the rate is undefined, or if the generator process is invalid.
#
# The handler function will be overwritten after performing an event, so the Perform method should be called
# only once for every Event object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An Event object.}
# \item{...}{Not used.}
# }
#
# \value{
# The value returned by the handler function.
# }
#
# \examples{
# # create a sequence and attach a process
# s<-NucleotideSequence(string="ATGC",processes=list(list(JC69())))
# # get the first active event from the first site
# #only Sequence methods set .position,
# #so s$sites[[1]]$events[[1]] wouldn't work.
# e<-getEvents(s,1)[[1]]
# # perform e
# Perform(e)
# # check the effect of the event on s
# s
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"Perform",
class="Event",
function(
this,
...
){
if(!exists(x="PSIM_FAST")){
if(!is.function(this$.handler)){throw("Event handler is not a function!\n")}
else if (!is.Site(this$.site)){throw("The site associated with the event is not valid!\n")}
else if(is.null(this$.position)){throw("The target site position is unknown!Refusing to perform event!\n")}
else if (!is.Process(this$.process)) {
throw("The event has no generator process. Refusing to perform!\n");
}
else if (is.na(this$.rate)) {
throw("The event has no rate. Refusing to perform!\n");
}
}
# Better not perform anything on a dirty object!
if(this$.site$.sequence$.cumulative.rate.flag) {
.recalculateCumulativeRates(this$.site$.sequence);
}
# Do NOT flag cumulative rate! The event should take care of that!
# Flag site if we deal with substitutions:
if( is.GeneralSubstitution( getProcess(this) ) ) {
this$.site$.sequence$.flagged.sites<-c(this$.site$.sequence$.flagged.sites, this$.position);
}
# Call the event handler to perform event:
output<-this$.handler(this);
# Event will self-destruct to prevent trouble:
if(!exists(x="PSIM_FAST")){
this$.handler<-function(event=this) { throw("You can perform an event only once!\n") };
}
return(output);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .setHandler
##
setMethodS3(
".setHandler",
class="Event",
function(
this,
new.handler,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(new.handler)){throw("No new handler provided!\n")}
else if (!is.function(new.handler)){throw("The handler must be a function!\n")}
}
this$.handler<-new.handler;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getWriteProtected
##
###########################################################################/**
#
# @RdocMethod getWriteProtected
#
# @title "Check if the object is write protected"
#
# \description{
# @get "title".
# Write protected objects cannot be modified through get/set methods and virtual fields.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
# \examples{
#
# # create an object
# o<-Event()
# # toggle write protection
# o$writeProtected<-TRUE
# # check if it's write protected
# getWriteProtected(o)
# # check write protection via virtual field
# o$writeProtected
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getWriteProtected",
class="Event",
function(
this,
...
){
this$.write.protected;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setWriteProtected
##
###########################################################################/**
#
# @RdocMethod setWriteProtected
#
# @title "Set the write protection field for an object"
#
# \description{
# @get "title".
# Write protected objects cannot be modified through get/set methods and virtual fields.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{A logical vector of size one.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE or FALSE.
# }
#
# \examples{
#
# # create an object
# o<-Event()
# # toggle write protection
# setWriteProtected(o,TRUE)
# # check write protection
# o$writeProtected
# # set write protection via virtual field
# o$writeProtected<-FALSE
# o$writeProtected
#
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setWriteProtected",
class="Event",
function(
this,
value,
...
){
if(!exists(x="PSIM_FAST")){
if(!is.logical(value)) {throw("The new value must be logical!\n")}
}
this$.write.protected<-value;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkWriteProtection
##
setMethodS3(
".checkWriteProtection",
class="Event",
function(
this,
value,
...
){
if(exists(x="PSIM_FAST")){return(FALSE)}
if(this$writeProtected) {throw("Cannot set value because the object is write protected!\n")}
else {return(FALSE)}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="Event",
function(
this,
...
){
wp<-this$writeProtected;
if(wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if (is.null(this$.name)){
throw("Event name is NULL!\n");
}
else if (!is.na(this$.name)) {
this$name<-this$name;
}
if (is.null(this$.rate)){
throw("Event rate is NULL!\n");
}
else if (!is.na(this$.rate)) {
this$rate<-this$rate;
}
if (is.null(this$.process)){
throw("Event rate is NULL!\n");
}
else if (!is.na(this$.process)) {
this$process<-this$process;
}
if (is.null(this$.site)){
throw("Event site is NULL!\n");
}
else if (!is.na(this$.site)) {
this$site<-this$site;
}
}
tryCatch(may.fail(this), finally=this$writeProtected<-wp);
return(invisible(TRUE))
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: as.character.Event
##
###########################################################################/**
#
# @RdocMethod as.character
#
# @title "Get the character representation of an Event object"
#
# \description{
# @get "title".
#
# The character represenation of an Event object has the following format:
# "event name" ("event rate") <-- "generator process id", like \code{"A->T (0.333333333333333) <-- JC69:Anonymous:44780832"}.
# }
#
# @synopsis
#
# \arguments{
# \item{x}{An Event object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a sequence and attach a process
# s<-NucleotideSequence(string="ATGC",processes=list(list(JC69())))
# # get the first active event from the first site
# e<-s$sites[[1]]$events[[1]]
# # get the character representation of e
# as.character(e)
# # or more simply
# e
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"as.character",
class="Event",
function(
x,
...
){
this<-x;
procid<-NA;
if(!is.na(this$.process)){
procid<-this$.process$.id;
}
paste(this$.name," (",this$.rate,")"," <-- ",procid,sep="");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.Event
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# e<-Event()
# # get a summary
# summary(e)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="Event",
function(
object,
...
){
this<-object;
this$.summary$"Name"<-this$.name;
this$.summary$"Rate"<-this$.rate;
procid<-NA;
if(!is.na(this$.process)){
procid<-this$.process$id;
}
this$.summary$"Generator process"<-procid;
site.state<-NA;
if(!is.na(this$.site)){
site.state<-getState(this$.site);
}
this$.summary$"Target site state"<-site.state;
if(this$writeProtected) {
this$.summary$"Write protected"<-TRUE;
}
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass FastFieldDeletor
#
# @title "The FastFieldDeletor class"
#
# \description{
# The \code{\link{DiscreteDeletor}} and \code{\link{ContinuousDeletor}} processes
# generate deletion event objects with rates determined by the general rate of the
# process and the "rate.multiplier" parameter. The probability of rejecting an event
# is determined by the product of the "deletion.tolerance" parameters from the affected sites.
# If the majority of the sites have low deletion tolerance most of the events are rejected, which
# slows down the simulation without performing much events.
#
# The \code{FastFieldDeletor} process scales down the rate and length distribution of the proposed
# events based on the highest insertion tolerance value observed in the root sequence
# (see the package vignette for details), thus making the simulation more efficient.
#
# The available length distributions are (see also the package vignette):
# \itemize{
# \item Geometric (default) - \code{lengthParam1} is \emph{Lambda}.
# \item Poisson+1 - \code{lengthParam1} is \emph{Lambda}.
# \item Conway-Maxwell Poisson+1 - \code{lengthParam1} is \emph{Lambda}, \code{lengthParam2} is \emph{nu}
# \item Negative Binomial+1 - \code{lengthParam1} is \emph{Lambda}, \code{lengthParam2} is \emph{r}
# }
#
# Insertion proceses can insert sites with deletion tolerance higher than the largest
# deletion tolerance observed in the root sequence. The user can specify the largest expected
# tolerance value through the \code{toleranceMargin} virtual field. The process is then scaled by
# max(initial_highest_tolerance, \code{toleranceMargin}).
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{type}{Type of the process (see above).}
# \item{length.param.1}{Object name.}
# \item{length.param.2}{Object name.}
# \item{tolerance.margin}{Object name.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a FastFieldDeletor object, default (geometric) type
# # length.param.1 is "lambda"
# p<-FastFieldDeletor(rate=1,length.param.1=0.9, tolerance.margin=0.8)
# # get type
# p$type
# # get object summary
# summary(p)
# # set/get lambda
# p$lengthParam1<-0.8
# p$lengthParam1
# # set/get tolerance margin
# p$toleranceMargin<-0.5
# p$toleranceMargin
# # create a nucleotide sequence, attach process
# s<-NucleotideSequence(length=30,processes=list(list(p)))
# # set state pattern
# s$states<-c("A","A","T","T","G","G","C","C")
# # sample deletion tolerances
# setDeletionTolerance(s,p,sample(seq(from=0,to=0.8,by=0.01),30,replace=TRUE))
# # plot deletion tolerance
# plotParametersAtSites(s,p,"deletion.tolerance")
# # simulate
# sim<-PhyloSim(root.seq=s, phylo=rcoal(2))
# Simulate(sim)
# # show alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setConstructorS3(
"FastFieldDeletor",
function(
name="Anonymous",
type="geometric",
length.param.1=NA, # mostly "Lambda"
length.param.2=NA,
tolerance.margin=0, # minimum tolerance value used for scaling.
...
) {
# supported types
ALLOWED.TYPES=c("geometric","poisson","neg.binomial","compoisson");
# Creating a GeneralDeletor Process.
this<-GeneralDeletor(
...
);
# Check if the specified type is valid:
if(length(intersect(ALLOWED.TYPES,type)) != 1){
throw("The specified field model type is invalid!\n");
}
# Extending as FastFieldDeletor:
this<-extend(
this,
"FastFieldDeletor",
.type=type, # field model flavour
.tolerance.margin=NA, # minimum tolerance used for scaling
.tolerance.max=NA, # maximum tolerance obseved at first call of
# getEventAtSites
.d=NA, # is max(.tolerance.max, .tolerance.margin)
.field.scaling.factor=NA,# the precalculated scaling factor
.length.param.1=NA, # mostly "Lambda"
.length.param.2=NA,
.ALLOWED.TYPES=ALLOWED.TYPES # supported types
);
# Set length parameter 1 if not missing:
if(!missing(length.param.1)){
this$lengthParam1<-length.param.1;
}
# Set length parameter 2 if not missing:
if(!missing(length.param.2)){
this$lengthParam2<-length.param.2;
}
# Set tolerance margin:
setToleranceMargin(this, tolerance.margin);
# Using virtual field to clear Id cache:
this$name<-name;
# Set the function proposing deletion lengths:
this$proposeBy<-function(process=NA,seq=NA,pos=NA){
# Check the length parameters:
.checkLengthParams(this);
# Check if this$.d is defined:
if(is.na(this$.d)){
throw("thid$.d is NA! This shouldn't happen!");;
}
d<-this$.d;
# Type specific length sampling expressions:
# Geometric + 1:
if(this$.type == "geometric"){
express<-expression(1 + rgeom(1,prob=( 1 - ( this$.length.param.1 * d) ) ) );
}
# Poisson+1:
else if(this$.type == "poisson"){
express<-expression( 1 + rpois(1,lambda=(this$.length.param.1 * d) ) );
}
# Negative Binomial + 1:
else if(this$.type == "neg.binomial"){
express<-expression(1 + rnbinom(1,this$.length.param.2,prob=( 1 - ( this$.length.param.1 * d))) );
}
# Conway-Maxwell Poisson + 1:
else if(this$.type == "compoisson"){
express<-expression(1 + rcom(1,lambda=( this$.length.param.1 * d), nu = this$.length.param.2));
}
return( round( eval(express) ) );
} # /proposeBy
# Set the function performing the accept/reject step:
this$acceptBy<-function(process=NA,sequence=NA,range=NA){
del.tol<-c();
for(site in sequence$.sites[range]){
# Reject if the range contains a site which is not attached to
# the process:
if(!isAttached(site, process)){
return(FALSE);
}
del.tol<-c(del.tol, getParameterAtSite(process, site, "deletion.tolerance")$value);
}
# Calculate acceptance probability:
accept.prob<-( prod(as.numeric(del.tol)) / this$.d );
# Accept/reject:
return( sample(c(TRUE,FALSE),replace=FALSE,prob=c(accept.prob,(1-accept.prob)),size=1) );
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: .checkLengthParams
##
setMethodS3(
".checkLengthParams",
class="FastFieldDeletor",
function(
this,
...
){
# Check length parameter 1:
if(is.na(this$.length.param.1)){
throw("Length parameter 1 is NA! Cannot generate events or propose lengths!\n");
}
# Check length parameter 2:
if(length(intersect(c("neg.binomial","compoisson"),this$.type)) != 0) {
if(is.na(this$.length.param.2)){
throw("Length parameter 1 is NA! Cannot generate events or propose lengths!\n");
}
}
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="FastFieldDeletor",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# Check if the type is valid:
if(length(intersect(this$.ALLOWED.TYPES, this$.type)) != 1){
throw("The specified field model type is invalid!\n");
}
if((!is.numeric(this$.tolerance.margin) & !is.na(this$.tolerance.margin))){
throw("Tolerance margin is invalid!\n");
}
if((!is.numeric(this$.tolerance.max) & !is.na(this$.tolerance.max))){
throw(".tolerance.max is invalid!\n");
}
if((!is.numeric(this$.d) & !is.na(this$.d))){
throw(".d is invalid!\n");
} else if(!is.na(this$.tolerance.margin) & !is.na(this$.tolerance.max)) {
if(this$.d != max(this$.tolerance.margin, this$.tolerance.max)){
throw(".d is inconsistent!\n");
}
}
if((!is.numeric(this$.field.scaling.factor) & !is.na(this$.field.scaling.factor))){
throw(".field.scaling.factor is invalid!\n");
}
if((!is.numeric(this$.length.param.1) & !is.na(this$.length.param.1))){
throw("Length parameter 1 is invalid!\n");
}
if((!is.numeric(this$.length.param.2) & !is.na(this$.length.param.2))){
throw("Length parameter 2 is invalid!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.FastFieldDeletor
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-FastFieldDeletor()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="FastFieldDeletor",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
this$.summary$"Type"<-this$.type;
this$.summary$"Tolerance margin"<-this$.tolerance.margin;
this$.summary$"Length parameter 1"<-this$.length.param.1;
this$.summary$"Length parameter 2"<-this$.length.param.2;
this$.summary$"Scaling factor"<-this$.field.scaling.factor;
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventsAtSite
##
###########################################################################/**
#
# @RdocMethod getEventsAtSite
#
# @title "Generate a deletion event object given the state of the target site"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A FastFieldDeletor object.}
# \item{target.site}{A Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of Event objects.
# }
#
#
# @author
#
# \seealso{
# GeneralDeletor getEventsAtSite.GeneralDeletor
# }
#
#*/###########################################################################
setMethodS3(
"getEventsAtSite",
class="FastFieldDeletor",
function(
this,
target.site,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(target.site)) {
throw("No target site provided!\n");
}
if(!is.Site(target.site)) {
throw("Target site invalid!\n");
}
else if(!is.function(this$.propose.by)) {
throw("proposeBy is not set, cannot propose deletion!\n");
}
else if (!is.function(this$.accept.by)){
throw("acceptBy is not set, cannot generate deletion event deletion!\n");
}
# Complain if sequence has a zero length:
if(target.site$.sequence$.length == 0) {
throw("Sequence has zero length so there is nothing to delete! How did you get here anyway?\n");
}
}
# Clone the event template object:
deletion.event<-clone(this$.event.template);
# Set the target position passed in a temporary field:
deletion.event$.position<-target.site$.position;
# Set the target site:
deletion.event$.site<-target.site;
# Set event name:
deletion.event$.name<-"Deletion";
# Set the generator process:
deletion.event$.process<-this;
# Calculate the field model specific scaling factor if it is not yet calculated:
if(is.na(this$.field.scaling.factor)){
this$.field.scaling.factor<-.getScalingFactor(this,process=this,seq=target.site$.sequence);
}
# Event rate is the product of the general rate, the field model scaling factor and the
# site specific rate multiplier:
deletion.event$.rate<-(this$.rate * (target.site$.processes[[this$.id]]$site.params[["rate.multiplier"]]$value) * this$.field.scaling.factor);
# Set the handler for the deletion event:
deletion.event$.handler<-this$.handler.template;
# Return the event object in a list:
list(deletion.event);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getType
##
###########################################################################/**
#
# @RdocMethod getType
#
# @title "Get the type of a FastFieldDeletor object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A FastFieldDeletor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a FastFieldDeletor, default type (geometric)
# p<-FastFieldDeletor()
# # get type
# getType(p)
# # create a FastFieldDeletor, poisson type
# p<-FastFieldDeletor(type="poisson")
# p$type
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getType",
class="FastFieldDeletor",
function(
this,
...
){
this$.type;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setType
##
###########################################################################/**
#
# @RdocMethod setType
#
# @title "Forbidden action: setting the type of a FastFieldDeletor object"
#
# \description{
# @get "title".
#
# The type can be set only through the \code{type} constructor argument.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setType",
class="FastFieldDeletor",
function(
this,
value,
...
){
throw("The type of the FastFieldDeletor process cannot be modified. Please set it by the constructor argument.");
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getLengthParam1
##
###########################################################################/**
#
# @RdocMethod getLengthParam1
#
# @title "Get the first length parameter"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A FastFieldDeletor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a geometric FastFieldDeletor
# p<-FastFieldDeletor()
# # set/get the first length parameter
# setLengthParam1(p,0.5)
# getLengthParam1(p)
# # set/get the first length parameter via virtual field
# p$lengthParam1<-0.2
# p$lengthParam1
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getLengthParam1",
class="FastFieldDeletor",
function(
this,
...
){
this$.length.param.1;
;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getLengthParam2
##
###########################################################################/**
#
# @RdocMethod getLengthParam2
#
# @title "Get the second length parameter"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A FastFieldDeletor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a geometric FastFieldDeletor
# p<-FastFieldDeletor()
# # set/get the second length parameter
# setLengthParam2(p,0.5)
# getLengthParam2(p)
# # set/get the second length parameter via virtual field
# p$lengthParam2<-0.2
# p$lengthParam2
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getLengthParam2",
class="FastFieldDeletor",
function(
this,
...
){
this$.length.param.2;
;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setLengthParam1
##
###########################################################################/**
#
# @RdocMethod setLengthParam1
#
# @title "Set the first length parameter"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A FastFieldDeletor object.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# value (invisible).
# }
#
# \examples{
# # create a geometric FastFieldDeletor
# p<-FastFieldDeletor()
# # set/get the first length parameter
# setLengthParam1(p,0.5)
# getLengthParam1(p)
# # set/get the first length parameter via virtual field
# p$lengthParam1<-0.2
# p$lengthParam1
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setLengthParam1",
class="FastFieldDeletor",
function(
this,
value,
...
){
if(missing(value)){
throw("No new length parameter value specified!\n");
}
else if ((!is.numeric(value)) | (length(value) != 1 ) ) {
throw("The new value must be a numeric vector of length 1!\n");
}
else {
# First set the scaling factor to NA to force the recalculation:
this$.field.scaling.factor<-NA;
this$.length.param.1<-value;
}
return(invisible(value));
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setLengthParam2
##
###########################################################################/**
#
# @RdocMethod setLengthParam2
#
# @title "Set the second length parameter"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A FastFieldDeletor object.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# value (invisible).
# }
#
# \examples{
# # create a geometric FastFieldDeletor
# p<-FastFieldDeletor()
# # set/get the second length parameter
# setLengthParam2(p,0.5)
# getLengthParam2(p)
# # set/get the second length parameter via virtual field
# p$lengthParam2<-0.2
# p$lengthParam2
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setLengthParam2",
class="FastFieldDeletor",
function(
this,
value,
...
){
if(missing(value)){
throw("No new length parameter value specified!\n");
}
else if ((!is.numeric(value)) | (length(value) != 1 ) ) {
throw("The new value must be a numeric vector of length 1!\n");
}
else {
# First set the scaling factor to NA to force the recalculation:
this$.field.scaling.factor<-NA;
this$.length.param.2<-value;
}
return(invisible(value));
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getToleranceMargin
##
###########################################################################/**
#
# @RdocMethod getToleranceMargin
#
# @title "Get the tolerance margin"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A FastFieldDeletor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a geometric FastFieldDeletor
# p<-FastFieldDeletor()
# # set/get tolerance margin
# setToleranceMargin(p,0.8)
# getToleranceMargin(p)
# # set/get tolerance margin via virtual field
# p$toleranceMargin<-0.75
# p$toleranceMargin
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getToleranceMargin",
class="FastFieldDeletor",
function(
this,
...
){
this$.tolerance.margin;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setToleranceMargin
##
###########################################################################/**
#
# @RdocMethod setToleranceMargin
#
# @title "Set the tolerance margin"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A FastFieldDeletor object.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# value (invisible).
# }
#
# \examples{
# # create a geometric FastFieldDeletor
# p<-FastFieldDeletor()
# # set/get tolerance margin
# setToleranceMargin(p,0.8)
# getToleranceMargin(p)
# # set/get tolerance margin via virtual field
# p$toleranceMargin<-0.75
# p$toleranceMargin
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setToleranceMargin",
class="FastFieldDeletor",
function(
this,
value,
...
){
if(missing(value)){
throw("No new length parameter value specified!\n");
}
else if ((!is.numeric(value)) | (length(value) != 1 ) ) {
throw("The new value must be a numeric vector of length 1!\n");
}
else {
# First set the scaling factor to NA to force the recalculation:
this$.field.scaling.factor<-NA;
this$.tolerance.margin<-value;
}
return(invisible(value));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .getScalingFactor
##
setMethodS3(
".getScalingFactor",
class="FastFieldDeletor",
function(
this,
process,
seq,
...
){
# Check if the length parameters needed for rate scaling are present:
.checkLengthParams(this);
if(is.na(this$.tolerance.max)){
# Get all deletion tolerance parameters for this process:
deletion.tolerance<-c();
for(site in seq$.sites){
if(isAttached(site, process)){
deletion.tolerance<-c(deletion.tolerance, getParameterAtSite(process, site, id="deletion.tolerance")$value);
}
} # for site
# Get the maximal tolerance value:
this$.tolerance.max<-max(deletion.tolerance);
}
d<-max(this$.tolerance.max, this$.tolerance.margin);
this$.d<-d;
# The type specific rate scaling factors:
exp<-expression();
# Geometric:
if(this$.type=="geometric"){
exp<-expression(d * (1 - this$.length.param.1) / (1 - (d * this$.length.param.1)) );
}
# Poisson+1:
else if(this$.type=="poisson"){
exp<-expression(d * exp( - ( this$.length.param.1 * (1 - d ) ) ) );
}
# Negative Binomial + 1:
else if(this$.type=="neg.binomial"){
exp<-expression( d * ( ( (1 - this$.length.param.1) / (1 - (d * this$.length.param.1))) ^ this$.length.param.2) );
}
# Conway-Maxwell Poisson + 1:
else if(this$.type=="compoisson"){
exp<-expression( d * (com.compute.z(lambda=this$.length.param.1,nu=this$.length.param.2 ) / com.compute.z(lambda=(d * this$.length.param.1),nu=this$.length.param.2 )) );
}
return(eval(exp));
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setParameterAtSite.FastFieldDeletor
##
setMethodS3(
"setParameterAtSite",
class="FastFieldDeletor",
function(
this,
site,
id,
value,
...
){
if(value < 0 | value > 1) {
throw("The field deletion model accepts deletion tolerance only from the [0,1] interval!\n");
}
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass GeneralInDel
#
# @title "The GeneralInDel class"
#
# \description{
#
# This is a class implementing the methods which are needed by both the
# GeneralInsertor and GeneralDeletor process.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{rate}{The general rate of the object.}
# \item{propose.by}{A function used to propose events.}
# \item{accept.by}{A function used to accept/reject events.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a GeneralInDel object
# # rejecting half of the events
# # and proposing sizes in the range 1:10
# o<-GeneralInDel(
# rate=1,
# propose.by=function(process){sample(1:10,1)},
# accept.by=function(){sample(c(TRUE,FALSE),1)}
# );
# # check if inherits from GeneralInDel
# is.GeneralInDel(o)
# # check if it has undefined rates
# hasUndefinedRate(o)
# # get object summary
# summary(o)
# # set/get proposeBy function via virtual field
# o$proposeBy<-function(process){return(3)} # fixed event length
# o$proposeBy
# # set/get acceptBy function via virtual field
# o$acceptBy<-function(){return(TRUE)} # accept all events
# o$acceptBy
# # get/set general rate
# o$rate
# o$rate<-2 # double the rate
# # propose event length
# proposeLength(o)
# }
#
# @author
#
# \seealso{
# Process GeneralInsertor GeneralDeletor GeneralSubstitution
# }
#
#*/###########################################################################
setConstructorS3(
"GeneralInDel",
function(
name="Anonymous",
rate=NA,
propose.by=NA,
accept.by=NA,
...
) {
any.alphabet<-AnyAlphabet();
this<-Process(
alphabet=any.alphabet
);
this<-extend(
this,
"GeneralInDel",
.rate=rate,
.propose.by=NA,
.accept.by=NA,
.is.general.indel=TRUE
);
# Using virtual field to clear Id cache:
this$name<-name;
# setting propose.by
if(!missing(propose.by) && is.function(propose.by)){
this$proposeBy<-propose.by;
}
# setting accept.by
if(!missing(accept.by) && is.function(accept.by)){
this$acceptBy<-accept.by;
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="GeneralInDel",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if (!is.na(this$rate)) {
this$rate<-this$rate;
}
if(!is.function(this$proposeBy)){
if(!is.na(this$proposeBy)){
throw("proposeBy is invalid!\n");
}
}
if(!is.function(this$acceptBy)){
if(!is.na(this$acceptBy)){
throw("acceptBy is invalid!\n");
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRate
##
###########################################################################/**
#
# @RdocMethod getRate
#
# @title "Get the general rate"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInDel object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a GeneralInDel object
# o<-GeneralInDel(rate=0.5)
# # get/set general rate
# getRate(o)
# setRate(o, 1.5)
# # get/set rate via virtual field
# o$rate
# o$rate<-0.3
# o$rate
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRate",
class="GeneralInDel",
function(
this,
...
){
this$.rate;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: hasUndefinedRate
##
###########################################################################/**
#
# @RdocMethod hasUndefinedRate
#
# @title "Check whether the general rate of a GeneralInDel object is undefined"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInDel object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create a GeneralInDel object
# o<-GeneralInDel()
# # check if the general rate is undefined
# hasUndefinedRate(o)
# # set general rate
# o$rate<-1
# # check rate again
# hasUndefinedRate(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"hasUndefinedRate",
class="GeneralInDel",
function(
this,
...
){
return(is.na(this$.rate));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRate
##
###########################################################################/**
#
# @RdocMethod setRate
#
# @title "Set the general rate"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInDel object.}
# \item{value}{The new general rate (a numeric vector of length one).}
# \item{...}{Not used.}
# }
#
# \value{
# The new general rate.
# }
#
# \examples{
# # create a GeneralInDel object
# o<-GeneralInDel(rate=0.5)
# # get/set general rate
# getRate(o)
# setRate(o, 1.5)
# # get/set rate via virtual field
# o$rate
# o$rate<-0.3
# o$rate
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRate",
class="GeneralInDel",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)) {
throw("No new value provided!\n");}
else if(!is.numeric(value)) {
throw("Rate must be numeric!\n");
}
}
this$.rate<-value;
return(this$.rate);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getProposeBy
##
###########################################################################/**
#
# @RdocMethod getProposeBy
# \alias{getProposeBy.GeneralInsertor}
#
# @title "Get the function used for proposing indel lengths"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInDel object.}
# \item{...}{Not used.}
# }
#
# \value{
# A function object.
# }
#
# \examples{
# # create a GeneralInDel object
# # proposing events with a constant length of 5
# o<-GeneralInDel(rate=1, propose.by=function(process){return(5)});
# # set/get the proposeBy function
# setProposeBy(o,value=function(process){return(6)})
# getProposeBy(o)
# # set/get proposeBy function via virtual field
# o$proposeBy<-function(process){return(3)}
# o$proposeBy
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getProposeBy",
class="GeneralInDel",
function(
this,
...
){
this$.propose.by;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setProposeBy
##
###########################################################################/**
#
# @RdocMethod setProposeBy
# \alias{setProposeBy.GeneralInsertor}
#
# @title "Set the function used for proposing indel lengths"
#
# \description{
# @get "title".
#
# The function must return a numeric vector of length one. The function must have an
# argument named "process" which will hold the calling process object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInDel object.}
# \item{value}{A function object returning a numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The function object (invisible).
# }
#
# \examples{
# # create a GeneralInDel object
# # proposing events with a constant length of 5
# o<-GeneralInDel(rate=1, propose.by=function(process){return(5)});
# # set/get the proposeBy function
# setProposeBy(o,value=function(process){return(6)})
# getProposeBy(o)
# # set/get proposeBy function via virtual field
# o$proposeBy<-function(process){return(3)}
# o$proposeBy
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setProposeBy",
class="GeneralInDel",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)) {
throw("No new value provided!\n");
}
else if(!is.function(value)){
throw("The value of proposeBy must be a function.!\n");
}
}
this$.propose.by<-value;
return(invisible(this$.propose.by));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAcceptBy
##
###########################################################################/**
#
# @RdocMethod getAcceptBy
# \alias{getAcceptBy.GeneralInsertor}
#
# @title "Get the function used for accepting/rejecting indel events"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInDel object.}
# \item{...}{Not used.}
# }
#
# \value{
# A function object.
# }
#
# \examples{
# # create a GeneralInDel object
# # rejecting half of the events
# o<-GeneralInDel(
# rate=1,
# propose.by=function(process){return(5)},
# accept.by=function( ){sample(c(TRUE,FALSE),1)}
# );
# # set/get the acceptBy function
# setAcceptBy(o,value=function(){return(FALSE)}) # reject all events
# getAcceptBy(o)
# # set/get acceptBy function via virtual field
# o$acceptBy<-function(){return(TRUE)} # accept all events
# o$acceptBy
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAcceptBy",
class="GeneralInDel",
function(
this,
...
){
this$.accept.by;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setAcceptBy
##
###########################################################################/**
#
# @RdocMethod setAcceptBy
# \alias{setAcceptBy.GeneralInsertor}
#
# @title "Set the function used for accepting/rejecting indel events"
#
# \description{
# @get "title".
#
# The function object must have the following arguments: process (the caller process), sequence (the target sequence),
# window (a vector containing the positions affecting acceptance).
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInDel object.}
# \item{value}{A function object.}
# \item{...}{Not used.}
# }
#
# \value{
# The function object (invisible).
# }
#
# \examples{
# # create a GeneralInDel object
# # rejecting half of the events
# o<-GeneralInDel(
# rate=1,
# propose.by=function(process){return(5)},
# accept.by=function( ){sample(c(TRUE,FALSE),1)}
# );
# # set/get the acceptBy function
# setAcceptBy(o,value=function( ){return(FALSE)}) # reject all events
# getAcceptBy(o)
# # set/get acceptBy function via virtual field
# o$acceptBy<-function(){return(TRUE)} # accept all events
# o$acceptBy
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setAcceptBy",
class="GeneralInDel",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)) {
throw("No new value provided!\n");
}
else if(!is.function(value)){
throw("The value of acceptBy must be a function.!\n");
}
}
this$.accept.by<-value;
return(invisible(this$.accept.by));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: proposeLength
##
###########################################################################/**
#
# @RdocMethod proposeLength
#
# @title "Propose indel length"
#
# \description{
# @get "title".
#
# This method simply calls the function returned by the \code{getProposeBy} method.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInDel object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one (the indel length).
# }
#
# \examples{
# # create a GeneralInDel object
# # proposing event lengths in the range 1:10
# o<-GeneralInDel(rate=1, propose.by=function(process){sample(c(1:10),1)});
# # propose indel length
# proposeLength(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"proposeLength",
class="GeneralInDel",
function(
this,
...
){
return( this$.propose.by(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: is.GeneralIndel
##
###########################################################################/**
# @RdocDefault is.GeneralInDel
#
# @title "Check if an object inherits from the GeneralInDel class"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
#
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create some objects
# o<-GeneralInDel(rate=1, propose.by=function(process){sample(c(1:10),1)});
# x<-GTR()
# # check if they inherit from GeneralInDel
# is.GeneralInDel(o)
# is.GeneralInDel(x)
# }
#
#
# @author
#
#*/###########################################################################
setMethodS3(
"is.GeneralInDel",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.general.indel)){return(TRUE)}
if ( inherits(this, "GeneralInDel")) {
this$.is.general.indel<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-GeneralInDel(rate=1,propose.by=function(process){sample(c(1,2,3),1)})
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="GeneralInDel",
function(
object,
...
){
.addSummaryNameId(object);
object$.summary$"General rate"<-object$rate;
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
###########################################################################
# Class:GeneralInsertor
##########################################################################/**
#
# @RdocClass GeneralInsertor
#
# @title "The GeneralInsertor class"
#
# \description{
#
# This is a class implementing a process generating insertion events.
# The rate of each event is calculated as the product of the general rate of the process
# and the "rate.multiplier" site-process specific parameter.
# The simulation code calls the \code{Perform} method on the selected insertion event objects,
# which call their insertion event handler to perform the insertion.
#
# The insert lengths are proposed by the function stored in the \code{proposeBy}
# virtual field. The function must have the following arguments:
# process (the insertion process object).
#
# The insertion events are accepted or rejected by the function stored in the \code{acceptBy} virtual field.
# The function must have the following arguments: process (the insertion process object), sequence (the target sequence object),
# window (a vector of positions affecting acceptance).
# The probability of accepting an insertion is calculated as the product of the site-process-specific
# "insertion.tolerance" parameters of the sites neighboring the insertion.
# The number of sites considered is determined by the \code{acceptWin} virtual field.
#
# The insert is generated by the \code{generateInsert} method by calling the function stored in the \code{generateBy} virtual field.
# The default generator function truncates/duplicates the sequence object stored in the \code{templateSeq} virtual field to get a sequence
# having the sampled length. After constructing the Sequence object, it calls the \code{sampleStates.Sequence} method on the resulting object.
# That means that if we start with a template sequence which has NA states, but has a substitution process attached, then the resulting sequence
# will be different every time.
#
# Before inserting the sequence returned by \code{generateInsert}, the handler function will pass the object through the function stored in the
# \code{insertHook} virtual field. This allows to perform arbitrary modifications on the inserted Sequence object.
#
# The sequence is inserted randomly on the left or the right of the target position.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{rate}{The general rate of the object (no default).}
# \item{propose.by}{A function used to propose events (no default).}
# \item{accept.by}{A function used to accept/reject events (no default).}
# \item{template.seq}{A Sequence object used as a template for generating insertions (no default).}
# \item{insert.hook}{A function object, see \code{setInsertHook} (no default).}
# \item{accept.win}{A window of sites affecting the acceptance of insert events.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a GeneralInsertor object
# i<-GeneralInsertor(
# name="GIN",
# rate=1,
# propose.by=function(process){4}, # fixed insert length
# acceptBy=function(process,sequence,window){TRUE},# always accept insertions
# template.seq=NucleotideSequence(string="A"),# a boring template sequence
# insert.hook=function(seq){ return(seq)},# a boring insert hook
# accept.win=2 #4 sites affecting acceptance
# )
# i
# # check if object inherits from GeneralInsertor
# is.GeneralInsertor(i)
# # get object summary
# summary(i)
# # set/get general rate
# i$rate<-0.5
# i$rate
# # set/get name
# i$name<-"Ins"
# i$name
# # set/get proposeBy
# # sample insertion length between 1 and 10
# i$proposeBy<-function(process){sample(1:10,1)}
# i$proposeBy
# # set/get acceptBy
# # reject half of the insertions
# i$acceptBy<-function(process, sequence, window){ sample(c(TRUE,FALSE), 1) }
# i$acceptBy
# # get generateBy
# i$generateBy
# # set/get acceptWin
# i$acceptWin<-1;
# # set/get insert hook
# i$insertHook<-function(
# seq,
# target.seq,
# event.pos,
# insert.pos
# ){ attachProcess(seq, GTR() );seq}
# i$insertHook
# # set/get template sequence
# i$templateSeq<-NucleotideSequence(
# length=5,
# processes=list(list(JC69()))
# ) # length: 5, states: NA
# i$templateSeq
# # generate an insert sequence
# generateInsert(i)
# # create a sequence object and attach the process i
# s<-NucleotideSequence(string="AAAAA",processes=list(list(i)))
# # set rate multiplier
# setRateMultipliers(s,i,2)
# # get the list of active events from site 2
# events<-getEventsAtSite(i,s$sites[[2]])
# events
# # set postition for event
# e<-events[[1]]
# e$.position<-2
# # print sequence
# s
# # perform event
# Perform(e)
# # check sequence again
# s
# }
#
# @author
#
# \seealso{
# GeneralInDel DiscreteInsertor ContinuousInsertor BrownianInsertor
# }
#
#*/###########################################################################
setConstructorS3(
"GeneralInsertor",
function(
name="Anonymous",
rate=NA,
propose.by=NA,
accept.by=NA,
template.seq=NA,
insert.hook=NA,
accept.win=NA,
...
) {
this<-GeneralInDel(
rate=rate,
propose.by=propose.by,
accept.by=accept.by
);
this<-extend(
this,
"GeneralInsertor",
.generate.by=NA,
.handler.template=NA,
.template.seq=NA,
.insert.hook=NA,
.accept.win=1,
.is.general.insertor=TRUE
);
# Using virtual field to clear Id cache:
this$name<-name;
# Adding insertion tolerance parameter.
.addSiteSpecificParameter(
this,
id="insertion.tolerance",
name="Insertion tolerance parameter",
value=as.double(1), # Accept all by default
type="numeric"
);
if(!missing(template.seq)){
this$templateSeq<-template.seq;
}
this$acceptBy<-function(process=NA,sequence=NA,range=NA){
accept.prob<-c();
for(site in sequence$.sites[range]){
# Discard the site if the process is not attached to it:
if(!isAttached(site, process)){
next();
}
else {
accept.prob<-c(accept.prob, getParameterAtSite(process, site, "insertion.tolerance")$value);
}
}
accept.prob<-prod(as.numeric(accept.prob));
# Accept/reject:
return( sample(c(TRUE,FALSE),replace=FALSE,prob=c(accept.prob,(1-accept.prob)),size=1) );
}
###
this$generateBy<-function(process=NA,length=NA,target.seq=NA,event.pos=NA,insert.pos=NA){
if(!exists(x="PSIM_FAST")){
if(is.na(length) | (length(length) == 0) | length == 0){
throw("Invalid insert length!\n");
}
else if(is.na(process$.template.seq)){
throw("Cannot generate insert without template sequence!\n");
}
}
times<-( ceiling( length/this$.template.seq$.length) );
to.delete<-( ( (this$.template.seq$.length) * times) - length);
tmp<-clone(this$.template.seq);
if( (times-1) > 0){
for(i in 1:(times-1)){
insertSequence(tmp,process$.template.seq,tmp$length);
}
}
if(to.delete > 0){
deleteSubSequence(tmp,(tmp$length - to.delete + 1):tmp$length);
}
return(tmp);
}
if(!missing(insert.hook)){
this$insertHook<-insert.hook;
}
###
this$.handler.template<-function(event=NA) {
if(!is.na(event)){
WINDOW.SIZE<-this$.accept.win;
# Using temporary varibales for clarity:
position<-event$.position;
process<-event$.process;
sequence<-event$.site$.sequence;
details<-list();
details$type<-"insertion";
# Propose the direction:
direction<-sample(c("LEFT","RIGHT"),replace=FALSE,size=1);
# Set insertion tolerance window:
window<-integer();
insert.pos<-position;
if(direction == "LEFT") {
window<-(position-WINDOW.SIZE):position;
insert.pos<-(position-1);
}
else if (direction == "RIGHT"){
window<-position:(position+WINDOW.SIZE);
}
else {
throw("You should never see this message!\n");
}
details$position<-insert.pos;
details$accepted<-FALSE;
# Discard illegal positions:
window<-window[ window > 0 & window <= sequence$.length];
if(process$.accept.by(process=process,sequence,window)){
details$accepted<-TRUE;
insert<-generateInsert(process,target.seq=sequence,event.pos=position,insert.pos=insert.pos);
details$length<-insert$length;
# Call the insert hook:
if(is.function(this$.insert.hook)){
insert<-this$.insert.hook(seq=insert,target.seq=sequence,event.pos=position,insert.pos=insert.pos);
}
insertSequence(sequence,insert, insert.pos,process=process);
}
return(details);
}
}
###
return(this);
},
enforceRCC=TRUE
);
##
## Method: is.GeneralInsertor
##
###########################################################################/**
#
# @RdocDefault is.GeneralInsertor
#
# @title "Check whether an object inherits from GeneralInsertor"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
#
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create some objects
# d<-GeneralDeletor()
# i<-GeneralInsertor()
# # check if they inherit from GeneralInsertor
# is.GeneralInsertor(i)
# is.GeneralInsertor(d)
# }
#
# @author
#
#*/###########################################################################
setMethodS3(
"is.GeneralInsertor",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.general.insertor)){return(TRUE)}
if ( inherits(this, "GeneralInsertor")) {
this$.is.general.insertor<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="GeneralInsertor",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if (!is.na(this$templateSeq)) {
this$templateSeq<-this$templateSeq;
}
if(!is.function(this$generateBy)){
if(!is.na(this$generateBy)){
throw("generateBy is invalid!\n");
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventsAtSite
##
###########################################################################/**
#
# @RdocMethod getEventsAtSite
#
# @title "Generate insertion event object given the state of the target site"
#
# \description{
# @get "title".
#
# This method generates a list with one insertion event. The rate of the
# event is calculated as the product of the general rate of the process
# and the "rate.multiplier" site-process specific parameter. An empty list is
# returned if the rate is zero or NA.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInsertor object.}
# \item{target.site}{A Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of Event objects.
# }
#
# \examples{
# # create a sequence object
# s<-NucleotideSequence(string="AAAA")
# # create a GeneralInsertor process, provide template sequence.
# # propsed insert lengths:3, always accept.
# i<-GeneralInsertor(
# rate=0.5,
# template.seq=NucleotideSequence(string="GGG"),
# propose.by=function(process){3},
# accept.by=function(process,sequence,window){TRUE}
# )
# # attach process to site
# s$processes<-list(list(i));
# # set rate multiplier
# setRateMultipliers(s,i,2)
# # get the list of active events from site 2
# events<-getEventsAtSite(i,s$sites[[2]])
# events
# # set postition for event
# e<-events[[1]]
# e$.position<-2
# # print sequence
# s
# # perform event
# Perform(e)
# # check sequence again
# s
# }
#
# @author
#
# \seealso{
# GeneralInsertor GeneralInDel Process Event
# }
#
#*/###########################################################################
setMethodS3(
"getEventsAtSite",
class="GeneralInsertor",
function(
this,
target.site,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(target.site)) {
throw("No target site provided!\n");
}
if(!is.Site(target.site)) {
throw("Target site invalid!\n");
}
else if(!is.function(this$.propose.by)) {
throw("proposeBy is not set, cannot propose insertion!\n");
}
else if (!is.function(this$.accept.by)){
throw("acceptBy is not set, cannot generate insertion event!\n");
}
}
# Just return an empty list if the rate is undefined or zero:
if( is.na(this$.rate) | this$.rate == 0) {
return(list());
}
# Clone the event template object:
insertion.event<-clone(this$.event.template);
# Set the target position passed in a temporary field:
insertion.event$.position<-target.site$.position;
# Set the target site:
insertion.event$.site<-target.site;
# Set event name:
insertion.event$.name<-"Insertion";
# Set the generator process:
insertion.event$.process<-this;
# Event rate is the product of the general rate and the
# site specific rate multiplier:
rate.multiplier<-target.site$.processes[[this$.id]]$site.params[["rate.multiplier"]]$value;
if(rate.multiplier == 0 ) {
return(list());
}
insertion.event$.rate<-(this$.rate * rate.multiplier );
# Set the handler for the insertion event:
insertion.event$.handler<-this$.handler.template;
# Return the event object in a list:
list(insertion.event);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: generateInsert
##
###########################################################################/**
#
# @RdocMethod generateInsert
#
# @title "Generate an insert"
#
# \description{
# @get "title".
#
# This method uses the function stgored in the \code{proposeBy} virtual field to
# sample the insert length and then calls the function stored in the \code{generateBy}
# field to generate the insert.
#
# The default \code{generateBy} function set by the GeneralInsertor constructor truncates/repeats
# the template sequence stored in the \code{templateSeq} field to have the sequence with the right size
# and then calls the \code{sampleStates} method on the resulting object. That means that if we start with a
# template sequence which has NA states, but has a substitution process attached, then the resulting sequence
# will be different every time the \code{generateInsert} method is called.
#
# The \code{generateBy}, \code{proposeBy} and \code{templateSeq} fields must be set in order to use this method.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInsertor object.}
# \item{length}{Generate an insert with the specified length if this argument is present.}
# \item{target.seq}{The Sequence object targeted by the insertion (optional). This argument is passed to the \code{generateBy} method.}
# \item{event.pos}{The position of the site proposing the insertion (optional). This argument is passed to the \code{generateBy} method.}
# \item{insert.pos}{The position of the insertion in the target sequence (optional). This argument is passed to the \code{generateBy} method.}
# \item{...}{Not used.}
# }
#
# \value{
# A Sequence object.
# }
#
# \examples{
# # build the template sequence
# ts<-NucleotideSequence(length = 10,processes=list(list(JC69())));
# # fix some site states
# setStates(ts,"A",c(1,2));
# setStates(ts,"T",c(5,6));
# setStates(ts,"C",c(9,10));
# # print template sequence
# ts
# # create a GeneralInsertor object
# i<-GeneralInsertor(
# rate=0.5,
# template.seq=ts,
# propose.by=function(process){sample(c(5:50),1)}, # inserts between 5 and 50
# )
# # generate some inserts
# generateInsert(i)
# generateInsert(i)
# generateInsert(i)
# generateInsert(i)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"generateInsert",
class="GeneralInsertor",
function(
this,
length=NA,
target.seq=NA,
event.pos=NA,
insert.pos=NA,
...
){
if(missing(length)){
length<-this$.propose.by(process=this);
}
insert<-this$.generate.by(process=this,length=length,target.seq=target.seq,event.pos=event.pos,insert.pos=insert.pos);
sampleStates(insert);
return(insert);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getGenerateBy
##
###########################################################################/**
#
# @RdocMethod getGenerateBy
#
# @title "Get the function object used for generating inserts"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInsertor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A function object.
# }
#
# \examples{
# # create a GeneralInsertor object
# i<-GeneralInsertor(
# rate=0.5,
# propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
# template.seq=NucleotideSequence(string="AAAAAAA")
# )
#
# # save insert generator
# old.gen<-getGenerateBy(i)
# # set a new insert generator
# i$generateBy<-function(
# process,
# length,
# target.seq,
# event.pos,
# insert.pos
# ){
# return(NucleotideSequence(string="AATTGGCC"))
# }
# # get the generator function
# i$generateBy
# # generate insert
# generateInsert(i)
# # restore old generator
# i$generateBy<-old.gen
# # generate insert
# generateInsert(i)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getGenerateBy",
class="GeneralInsertor",
function(
this,
...
){
this$.generate.by;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setGenerateBy
##
###########################################################################/**
#
# @RdocMethod setGenerateBy
#
# @title "Set the function object used for generating inserts"
#
# \description{
# @get "title".
# The provided function must return a Sequence object whne called and must have the
# following arguments: process, length, target.seq, event.pos, insert.pos (see \code{generateInsert.GeneralInsertor}).
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInsertor object.}
# \item{value}{A function object.}
# \item{...}{Not used.}
# }
#
# \value{
# The function object.
# }
#
# \examples{
# # create a GeneralInsertor object
# i<-GeneralInsertor(
# rate=0.5,
# propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
# template.seq=NucleotideSequence(string="AAAAAAA")
# )
#
# # save insert generator
# old.gen<-getGenerateBy(i)
# # set a new insert generator
# i$generateBy<-function(
# process,
# length,
# target.seq,
# event.pos,
# insert.pos){
# return(NucleotideSequence(string="AATTGGCC"))
# }
# # get the generator function
# i$generateBy
# # generate insert
# generateInsert(i)
# # restore old generator
# i$generateBy<-old.gen
# # generate insert
# generateInsert(i)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setGenerateBy",
class="GeneralInsertor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)) {
throw("No new value provided!\n");
}
else if(!is.function(value)){
throw("The value of generateBy must be a function.!\n");
}
}
this$.generate.by<-value;
return(this$.generate.by);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getTemplateSeq
##
###########################################################################/**
#
# @RdocMethod getTemplateSeq
#
# @title "Get the template sequence object"
#
# \description{
# @get "title".
# The template sequence object is used by the default \code{generateBy} function
# to generate insert sequences.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInsertor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A Sequence object or NA.
# }
#
# \examples{
# # create a GeneralInsertor object
# i<-GeneralInsertor(
# rate=0.5,
# propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
# template.seq=NucleotideSequence(string="AAAAAAA")
# )
# # get template sequence
# getTemplateSeq(i)
# # get template sequence via virtual field
# i$templateSeq
# # set template sequence
# setTemplateSeq(i, NucleotideSequence(string="C"));
# # generate insert
# generateInsert(i)
# # set template sequence via virtual field
# i$templateSeq<-NucleotideSequence(string="G")
# # generate insert
# generateInsert(i)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getTemplateSeq",
class="GeneralInsertor",
function(
this,
...
){
this$.template.seq;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setTemplateSeq
##
###########################################################################/**
#
# @RdocMethod setTemplateSeq
#
# @title "Set the template sequence object"
#
# \description{
# @get "title".
# The template sequence object is used by the default \code{generateBy} function
# to generate insert sequences.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInsertor object.}
# \item{value}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object.
# }
#
# \examples{
# # create a GeneralInsertor object
# i<-GeneralInsertor(
# rate=0.5,
# propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
# template.seq=NucleotideSequence(string="AAAAAAA")
# )
# # get template sequence
# getTemplateSeq(i)
# # get template sequence via virtual field
# i$templateSeq
# # set template sequence
# setTemplateSeq(i, NucleotideSequence(string="C"));
# # generate insert
# generateInsert(i)
# # set template sequence via virtual field
# i$templateSeq<-NucleotideSequence(string="G")
# # generate insert
# generateInsert(i)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setTemplateSeq",
class="GeneralInsertor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)) {
throw("No new template sequence provided!\n");
}
else if(!is.Sequence(value)){
throw("Sequence object is invalid!\n");
}
else if(value$length == 0) {
throw("Cannot set template sequence of length zero!\n");
}
}
this$.template.seq<-clone(value);
for (site in this$.template.seq$.sites){
site$.ancestral<-this;
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAcceptWin
##
###########################################################################/**
#
# @RdocMethod getAcceptWin
#
# @title "Get the size of the acceptance window"
#
# \description{
# @get "title"
#
# This parameter determines the number of sites neighbouring the position (from left and right) of the insertion considered when accepting/rejecting
# a proposed insertion. The "insertion.tolerance" parameter is retrived from sites falling in the window specified by this parameter.
# The default value is 1, so the two neighbouring sites are considered by default.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInsertor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a GeneralInsertor object
# i<-GeneralInsertor(rate=0.5);
# # get acceptance window size
# getAcceptWin(i)
# # get acceptance window size via virtual field
# i$acceptWin
# # set acceptance window size
# setAcceptWin(i,2)
# # set acceptance window size via virtual field
# i$acceptWin<-3
# i$acceptWin
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAcceptWin",
class="GeneralInsertor",
function(
this,
...
){
this$.accept.win;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setAcceptWin
##
###########################################################################/**
#
# @RdocMethod setAcceptWin
#
# @title "Set the size of the acceptance window"
#
# \description{
# @get "title"
#
# This parameter determines the number of sites neighbouring the position (from left and right) of the insertion considered when accepting/rejecting
# a proposed insertion. The "insertion.tolerance" parameter is retrived from sites falling in the window specified by this parameter.
# The default value is 1, so the two neighbouring sites are considered by default.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInsertor object.}
# \item{value}{An integer vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value.
# }
#
# \examples{
# # create a GeneralInsertor object
# i<-GeneralInsertor(rate=0.5);
# # get acceptance window size
# getAcceptWin(i)
# # get acceptance window size via virtual field
# i$acceptWin
# # set acceptance window size
# setAcceptWin(i,2)
# # set acceptance window size via virtual field
# i$acceptWin<-3
# i$acceptWin
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setAcceptWin",
class="GeneralInsertor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)){
throw("No new value provided");
}
else if(!all(is.numeric(value)) | (length(value) != 1)){
throw("The new value must be a numeric vector of length one.");
}
}
this$.accept.win<-floor(value);
return(this$.accept.win);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getInsertHook
##
###########################################################################/**
#
# @RdocMethod getInsertHook
#
# @title "Get the insert hook function"
#
# \description{
# @get "title".
#
# The insert hook allows to make various modifications on the insert before performing the insertion.
#
# The insert hook function is called by the insertion event handler function. The insert hook takes the
# sequence generated by the \code{generateInsert} method throught the "seq" argument. The function
# must return a Sequnece object, which will be inserted in the target sequence.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInsertor object.}
# \item{...}{Not used.}
# }
#
# \value{
# A function object.
# }
#
# \examples{
# # create a GeneralInsertor object
# i<-GeneralInsertor(
# rate=0.5,
# propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
# template.seq=NucleotideSequence(length=5,processes=list(list(JC69())))
# )
# # set a dummy insert hook
# setInsertHook(i,function(seq){return(seq)})
# # set a new insert hook via virtual field
# i$insertHook<-function(seq){
# seq$processes<-list(list(GTR())) # replace the subsitution process
# return(seq)
# }
# # get the insert hook via virtual field
# i$insertHook
# # get the insert hook
# getInsertHook(i)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getInsertHook",
class="GeneralInsertor",
function(
this,
...
){
this$.insert.hook;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setInsertHook
##
###########################################################################/**
#
# @RdocMethod setInsertHook
#
# @title "Set the insert hook function"
#
# \description{
# @get "title".
#
# The insert hook allows to make various modifications on the insert before performing the insertion.
# The function must have the following arguments: seq (the sequence object to insert), target.seq (the target Sequence object),
# event.pos (the position of the site which generated the insertion event), insert.pos (the position of the insertion).
#
# The insert hook function is called by the insertion event handler function. The insert hook takes the
# sequence generated by the \code{generateInsert} method throught the "seq" argument. The function
# must return a Sequnece object, which will be inserted in the target sequence.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralInsertor object.}
# \item{value}{A function object.}
# \item{...}{Not used.}
# }
#
# \value{
# The function object.
# }
#
# \examples{
# # create a GeneralInsertor object
# i<-GeneralInsertor(
# rate=0.5,
# propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
# template.seq=NucleotideSequence(length=5,processes=list(list(JC69())))
# )
# # set a dummy insert hook
# setInsertHook(i,function(seq){return(seq)})
# # set a new insert hook via virtual field
# i$insertHook<-function(seq){
# seq$processes<-list(list(GTR())) # replace the subsitution process
# return(seq)
# }
# # get the insert hook via virtual field
# i$insertHook
# # get the insert hook
# getInsertHook(i)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setInsertHook",
class="GeneralInsertor",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!is.Sequence(this$.template.seq)){
throw("Cannot set insert hook because the template sequence is not defined!\n");
}
if(missing(value)) {
throw("No new value provided!\n");
}
else if(!is.function(value)){
throw("The insert hook must be a function.!\n");
}
else if( length(intersect(names(formals(value)), "seq")) == 0 ){
throw("The insert hook function must have a an argument named \"seq\"");
}
else if(!is.Sequence(value(generateInsert(this,length=1)))){
throw("The insert hook function must return a Sequence object!\n");
} else {
this$.insert.hook<-value;
}
return(this$.insert.hook);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-GeneralInsertor(rate=1)
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="GeneralInsertor",
function(
object,
...
){
.addSummaryNameId(object);
object$.summary$"Accept window size"<-object$.accept.win;
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
###########################################################################
# Class:GeneralDeletor
##########################################################################/**
#
# @RdocClass GeneralDeletor
#
# @title "The GeneralDeletor class"
#
# \description{
# This is the class implementing a process generating deletion events.
# The rates of the deletion events are calculated as the product of the general rate
# of the process and the "rate.multiplier" site-process-specific parameter.
#
# The simulation code calls the \code{Perform} method on the selected
# deletion event objects, which call their handler function to perform the deletion.
#
# The deletion lengths are proposed by the function stored in the \code{proposeBy} virtual field.
# The function must have the following arguments: process (the process object), sequence (the target sequence),
# position (the position of the site which generated the event).
#
# The deletion randomly affects the sites from the left or from the right of the target position (but never both).
# Positions which are out of range are discarded.
#
# The proposed deletions are accepted or rejected by the function stored in the \code{acceptBy} virtual field.
# The function must have the following arguments: process (the deletion prcoess), sequence (the target sequence), range (a vector of positions
# affected by the deletion).
#
# The probability of accepting a deletion is calculated as the product of the "deletion.tolerance" site-process-specific
# parameters from the sites affected by the deletion event.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{rate}{The general rate of the object.}
# \item{propose.by}{A function used to propose events.}
# \item{accept.by}{A function used to accept/reject events.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a GeneralDeletor object
# # proposed deletion length: 4, always accept
# d<-GeneralDeletor(
# name = "DEL",
# rate = 1,
# propose.by=function(process, sequence, position){ 4 },
# accept.by=function(process, sequence, range){ TRUE }
# )
# d
# # check if object inherits from GeneralDeletor
# is.GeneralDeletor(d)
# # get object summary
# summary(d)
# # set/get name
# d$name<-"Del Bosque"
# d$name
# # set/get rate
# d$rate<-0.5
# d$rate
# # set/get proposeBy
# # propose deletion lengths between 3 and 6
# d$proposeBy<-function(process, sequence, position){ sample(3:6,1) }
# d$proposeBy
# # set/get acceptBy
# # reject half of the events
# d$acceptBy<-function(process, sequence, range){ sample(c(TRUE, FALSE), 1)}
# d$acceptBy
# # create a sequence object, attach process
# s<-NucleotideSequence(string="AATTGGCCCCGGTTAA", processes=list(list(d)))
# # set the rate multiplier
# setRateMultipliers(s,d,2)
# # get the list of active events at site 6
# events<-getEventsAtSite(d,s$sites[[6]])
# events;
# # print sequence
# s
# # set the position for the event object
# e<-events[[1]];
# e$.position<-6;
# # perform the deletion event
# Perform(e)
# # check the results
# s
# }
#
# @author
#
# \seealso{
# GeneralInDel DiscreteDeletor ContinuousDeletor FastFieldDeletor
# }
#
#*/###########################################################################
setConstructorS3(
"GeneralDeletor",
function(
name="Anonymous",
rate=NA,
propose.by=NA,
accept.by=NA,
...
) {
this<-GeneralInDel(
rate=rate,
propose.by=propose.by,
accept.by=accept.by
);
this<-extend(
this,
"GeneralDeletor",
.handler.template=NA,
.is.general.deletor=TRUE
);
# Using virtual field to clear Id cache:
this$name<-name;
# Adding insertion tolerance parameter.
.addSiteSpecificParameter(
this,
id="deletion.tolerance",
name="Deletion tolerance parameter",
value=as.double(1), # Accept all by default
type="numeric"
);
this$acceptBy<-function(process=NA,sequence=NA,range=NA){
accept.prob<-c();
for(site in sequence$.sites[range]){
# Reject if the range contains a site which is not attached to
# the process:
if(!isAttached(site, process)){
return(FALSE);
}
accept.prob<-c(accept.prob, getParameterAtSite(process, site, "deletion.tolerance")$value);
}
# Calculate the product of the per-site
# acceptance probabilities.
accept.prob<-prod(as.numeric(accept.prob));
# Accept/reject:
return( sample(c(TRUE,FALSE),replace=FALSE,prob=c(accept.prob,(1-accept.prob)),size=1) );
}
this$.handler.template<-function(event=NA) {
if(!is.na(event)){
# Using temporary varibales for clarity:
position<-event$.position;
process<-event$.process;
sequence<-event$.site$.sequence;
details<-list();
details$type<-"deletion";
details$accepted<-FALSE;
# Propose a sequence length:
length<-process$.propose.by(process=process,seq=sequence, pos=position);
# Propose the direction:
direction<-sample(c("LEFT","RIGHT"),replace=FALSE,size=1);
# Calculate the sites to delete:
range<-numeric();
if(direction == "RIGHT") {
range<-position:(position+length-1);
} else if(direction == "LEFT") {
range<-(position-length+1):position;
} else {
throw("You should never see this message!\n");
}
# Discard potential negative values and values larger than the sequence length:
range<-range[ range > 0 & range <= sequence$.length];
details$range<-c(min(range),max(range));
# Perform the deletion if it is accepted:
if (process$.accept.by(process=process,sequence=sequence,range=range) == TRUE) {
details$accepted<-TRUE;
deleteSubSequence(sequence,range);
}
# Return event details:
return(details);
}
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: is.GeneralDeletor
##
###########################################################################/**
#
# @RdocDefault is.GeneralDeletor
#
# @title "Check whether an object inherits from GeneralDeletor"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
#
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create some objects
# d<-GeneralDeletor()
# i<-GeneralInsertor()
# # check if they inherit from GeneralDeletor
# is.GeneralDeletor(d)
# is.GeneralDeletor(i)
# }
#
#
# @author
#
#*/###########################################################################
setMethodS3(
"is.GeneralDeletor",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.general.deletor)){return(TRUE)}
if ( inherits(this, "GeneralDeletor")) {
this$.is.general.deletor<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="GeneralDeletor",
function(
this,
...
){
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventsAtSite
##
###########################################################################/**
#
# @RdocMethod getEventsAtSite
#
# @title "Title"
#
# \description{
# @get "title".
#
# This method generates a list containing a single deletion event object. The rate
# of the event is calculated as the product of the general rate of the process and the
# "rate.multiplier" site-process specific parameter. An empty list is
# returned if the rate is zero or NA.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralDeletor object.}
# \item{target.site}{The target Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of event objects.
# }
#
# \examples{
# # create the Sequence object
# s<-NucleotideSequence(string="ATGCCCGGCGGATTTATTA");
# # create a GeneralDeletor object
# # proposed deletion length: 4, always accept
# d<-GeneralDeletor(
# name = "Del Bosque",
# rate = 0.5,
# propose.by=function(process, sequence, position){ 4 },
# accept.by=function(process, sequence, range){ TRUE }
# )
# # attach process to site
# attachProcess(s,d);
# # set the rate multiplier
# setRateMultipliers(s,d,2)
# # get the list of active events at site 6
# events<-getEventsAtSite(d,s$sites[[6]])
# events;
# # print sequence
# s
# # set the position for the event object
# e<-events[[1]];
# e$.position<-6;
# # perform the deletion event
# Perform(e)
# # check the results
# s
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEventsAtSite",
class="GeneralDeletor",
function(
this,
target.site,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(target.site)) {
throw("No target site provided!\n");
}
if(!is.Site(target.site)) {
throw("Target site invalid!\n");
}
else if(!is.function(this$.propose.by)) {
throw("proposeBy is not set, cannot propose deletion!\n");
}
else if (!is.function(this$.accept.by)){
throw("acceptBy is not set, cannot generate deletion event deletion!\n");
}
# Complain if sequence has a zero length:
if(target.site$.sequence$.length == 0) {
throw("Sequence has zero length so there is nothing to delete! How did you get here anyway?\n");
}
}
# Clone the event template object:
deletion.event<-clone(this$.event.template);
# Set the target position passed in a temporary field:
deletion.event$.position<-target.site$.position;
# Set the target site:
deletion.event$.site<-target.site;
# Set event name:
deletion.event$.name<-"Deletion";
# Set the genrator process:
deletion.event$.process<-this;
# Event rate is the product of the general rate and the
# site specific rate multiplier:
rate.multiplier<-target.site$.processes[[this$.id]]$site.params[["rate.multiplier"]]$value;
deletion.event$.rate<-(this$.rate * rate.multiplier);
# Set the handler for the deletion event:
deletion.event$.handler<-this$.handler.template;
# Return the event object in a list:
list(deletion.event);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-GeneralDeletor(rate=1,name="Del Bosque")
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="GeneralDeletor",
function(
object,
...
){
.addSummaryNameId(object);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass GeneralSubstitution
#
# @title "The GeneralSubstitution class"
#
# \description{
# This a class representing a continuous-time Markov process acting
# on the state space defined by the symbols stored in the Alphabet object
# passed to the object constructor.
#
# The GeneralSubstitution objects generate
# Event objects corresponding to substitution events based on the state of the
# attached Site objects.
#
# The GeneralSubstitution objects aggregate a QMatrix object, which stores the
# unscaled and scaled rate matrices. The scaled rate matrices, along with the
# site-process specific rate multiplier parameters define the rates of the generated
# Event objects.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{alphabet}{The alphabet on which the process acts (Alphabet object).}
# \item{rate.list}{A list with the substitution rates. It will be passed to \code{setRateList} method.}
# \item{equ.dist}{The equilibrium distribution (see \code{setEquDist.GeneralSubstitution}).}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # Create a GeneralSubstitution object
# # also provide an Alphabet objects
# # and the list of unscaled rates
# a<-BinaryAlphabet()
# gs<-GeneralSubstitution(
# name="MyBinarySubst",
# alphabet=a,
# rate.list=list("0->1"=2,"1->0"=1)
# )
# # check if inherits from GeneralSubstitution
# is.GeneralSubstitution(gs)
# # get an object summary
# summary(gs)
# # get a bubble plot
# plot(gs)
# # get unscaled rate for "0->1" by event name
# getRate(gs,"0->1")
# # get unscaled rate for "0->1" by states
# getRate(gs,from="0", to="1")
# # get scaled rate for "0->1" by name
# getEventRate(gs,"0->1")
# # get the list of unscaled event rates
# gs$rateList
# # set the \emph{unscaled} rates
# gs$rateList<-list("0->1"=1,"1->0"=1)
# # reset equilibrium distribution
# gs$equDist<- 5 * gs$equDist
# # get the equilibrium distribution
# gs$equDist
# # sample a state form the equilibrium distribution
# sampleState(gs)
# # get the associated QMatrix object
# gs$qMatrix
# # create a site object
# s<-Site(alphabet=a, state="0")
# # attach gs to s
# s$processes<-list(gs)
# # set rate multiplier for s and gs
# setParameterAtSite(gs,s,id="rate.multiplier",value=2)
# # get site specific rate for "0->1"
# getEventsAtSite(gs,s,"0->1")
# # get the list of active event objects given the state of s
# getEventsAtSite(gs,s)
# # get the associated Alphabet object
# gs$alphabet
# # clone the object
# gsc<-clone(gs)
# # modify the alphabet of gsc
# gsc$alphabet<-NucleotideAlphabet()
# summary(gsc)
# # check if gsc has undefined rates
# hasUndefinedRate(gsc)
# }
#
# @author
#
# \seealso{
# Process QMatrix Event Site GeneralIndel GTR WAG
# }
#
#*/###########################################################################
setConstructorS3(
"GeneralSubstitution",
function(
name="Anonymous",
alphabet=NA,
rate.list=NA,
equ.dist=NA,
...
) {
# Set an empty alphabet by default
# to satisfy the static instance:
if(missing(alphabet)){
alphabet<-Alphabet(name="Undefined");
}
this<-Process(
name=name,
alphabet=alphabet
);
this<-extend(
this,
"GeneralSubstitution",
.q.matrix=NA,
.equ.dist=NA,
.handler.template=NA,
.is.general.substitution=TRUE
);
# Initialize with NA-s equDist:
if (missing(equ.dist)){
.initEquDist(this);
} else {
# or set if we have one:
this$equDist<-equ.dist;
}
# Create the QMatrix object:
qm<-QMatrix(name=name, alphabet=alphabet);
# Set the rates:
if(!missing(rate.list)){
qm$rateList<-rate.list;
}
# Attach the QMatrix to the process:
this$.q.matrix<-qm;
this$.q.matrix$process<-this;
# Try to guess the equlibrium distribution:
if (missing(equ.dist) & !missing(rate.list)){
if(.setEquDistFromGuess(this)){
# and perfrom rescaling if suceeded:
rescaleQMatrix(this);
}
}
# Using virtual field to clear Id cache:
this$name<-name;
# Set the template for handling substitution events:
this$.handler.template<-function(event=NA){
# Just set the new state base on the event name:
setState(event$.site, strsplit(event$.name,split="->",fixed=TRUE)[[1]][[2]]);
# The name *should* be valid and correct, so no more checking is needed.
# Return details:
return(
list(
type="substitution",
accepted=TRUE
)
);
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="GeneralSubstitution",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# The process must have a valid alphabet object:
if(!is.Alphabet(this$.alphabet)){
throw("Alphabet object is invalid!\n");
}
# Name:
if(!is.na(this$name)){
this$name<-this$name;
}
# EquDist:
if(!any(is.na(this$.equ.dist))){
this$equDist<-this$equDist;
}
# Negative rates are impossible:
if(all(!is.na(this$rateList)) & any(as.numeric(this$rateList) < 0 )){
throw("The rate matrix has negative off-diagonal elements!\n");
}
# QMatrix should never be NA!
this$QMatrix<-this$QMatrix;
# Further checks if survived the one above:
checkConsistency(this$.q.matrix,check.process=FALSE);
if(is.Process(this$.q.matrix$.process)){
# Check for alphabet compatibility:
if(this$.alphabet != this$.q.matrix$.process$alphabet){
throw("Process/QMatrix alphabet mismatch!\n");
}
# Check if the parent process QMatrix is this object:
if(!equals(this$.q.matrix$.process, this) ){
throw("QMatrix process is not identical with self!\n");
}
} else if(!is.na(this$.q.matrix$.process)){
throw("QMatrix process entry is invalid!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventsAtSite
##
###########################################################################/**
#
# @RdocMethod getEventsAtSite
#
# @title "Generate the list of active Event objects for a given attached Site object"
#
# \description{
# @get "title".
#
# This is the single most important method in the \code{GeneralSubstitution} class. It generates a list of the active
# Event objects given the transition rate matrix (Q matrix) and the "rate.multiplier" Site-Process specific parameter.
# It returns an empty list if the state of the site is "NA".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{target.site}{A Site object. The GeneralSubstitution object must be attached to the Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of the active Event objects.
# }
#
# \examples{
# # create an Alphabet object
# a<-BinaryAlphabet()
# # create a Site object
# s<-Site(alphabet=a);
# # create a GeneralSubstitution object
# p<-GeneralSubstitution(alphabet=a,rate.list=list("0->1"=1,"1->0"=1))
# # attach process p to site object s
# attachProcess(s,p)
# # get the rate of active events
# getEventsAtSite(p,s) # empty list
# # set the state of s
# s$state<-1;
# # get the rate of active events
# getEventsAtSite(p,s)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEventsAtSite",
class="GeneralSubstitution",
function(
this,
target.site,
...
){
# The main method of this class,
# generating a list of event objects given the
# state of the target site.
if(!exists(x="PSIM_FAST")){
if(missing(target.site)) {
throw("No target site provided!\n");
}
}
# The following code is commented out to
# increase speed
#else if (!sloppy) {
# Additional checks. They can be
# disabled by sloppy=TRUE
#if(!is.Site(target.site)) {
# throw("Target site invalid!\n");
#}
#else if(!is.QMatrix(this$.q.matrix)){
# throw("Cannot provide event objects because the rate matrix is not set!\n");
#}
#else if(!is.numeric(this$.equ.dist)){
# throw("Cannot provide event objects because the equilibrium frequencies are not defined!\n");
#}
#}
state<-as.character(target.site$.state);
# Just return an empty list if the state is NA:
if(is.na(state)){
return(list());
}
# The rate of the event is the product of the general rate and the
# site specific rate multiplier:
rate.multiplier<-target.site$.processes[[this$.id]]$site.params[["rate.multiplier"]]$value;
# Return empty list if the rate multiplier is zero.
if(rate.multiplier == 0 ) {
return(list());
}
# Get rate matrix:
rate.matrix<-this$.q.matrix$.rate.matrix;
symbols<-this$.alphabet$.symbols;
rest<-symbols[ which(symbols != state) ];
# Create the event objects:
events<-list();
for(new.state in rest){
name<-paste(state,new.state,sep="->");
# Clone the event template object:
event<-clone(this$.event.template);
# Set event name:
event$.name<-name;
# Set the generator process:
event$.process<-this;
# Set the target position passed in a temporary field,
# Event objects are not aware of their posiitions in general!
event$.position<-target.site$.position;
# Set the target site:
event$.site<-target.site;
# Set the event rate:
event$.rate<-(rate.multiplier * (rate.matrix[state,new.state]));
# Set the handler for the substitution event:
event$.handler<-this$.handler.template;
# Add to events list:
events<-c(events, list(event));
}
return(events);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setEquDist
##
###########################################################################/**
#
# @RdocMethod setEquDist
# \alias{setEquDist.AminoAcidSubst}
#
# @title "Set the equilibrium distribution for a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# In the case the equlibrium distribution cannot be guessed from the rate matrix one should provide
# a valid equilibrium distribution. The equilibrium distribution must be compatible with the rate matrix.
# The provided numeric vector will be resacled in the case the sum of the elemnts is not one.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{value}{A numeric vector containing the equlibrium symbol frequencies. The order of the frequencies must be the same as in the symbol vector of the attached Alphabet object.}
# \item{force}{Do not check compatibility with thr rate matrix.}
# \item{silent}{Do not print out warnings.}
# \item{...}{Not used.}
# }
#
# \value{
# The new equlibrium distribution (invisible).
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(
# alphabet=BinaryAlphabet(),
# rate.list=list("1->0"=1,"0->1"=1)
# )
# # get equlibrium distribution
# getEquDist(p)
# # get equilibrium distribution via virtual field
# p$equDist
# # re-set the equilibrium distribution
# dist<-p$equDist * 3
# dist
# setEquDist(p,dist)
# p$equDist
# # re-set equilibrium distribution via virtual field
# p$equDist<-p$equDist * 2
# p$equDist
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setEquDist",
class="GeneralSubstitution",
function(
this,
value,
force=FALSE,
silent=FALSE,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(!is.Alphabet(this$alphabet)){
throw("Cannot set equilibrium distribution because the alphabet is undefined!");
}
if(missing(value)) {
throw("No new value provided!\n");}
else if(!is.numeric(value)) {
throw("The new value must be numeric!\n");
}
}
if(length(value) != this$alphabet$size){
throw("The new value must be a vector of length ",this$alphabet$size,"!\n");
}
if(!PSRoot$my.all.equal(sum(value), 1.0)) {
value<-(value/sum(value));
if (silent == FALSE){
warning("The provided probabilities have been rescaled in order to sum to one!\n");
}
}
if(!exists(x="PSIM_FAST")){
# Check if the provided equlibrium distribution is
# compatible with the rate matrix:
if( !.checkEquMatCompat(this, rbind(value)) & force==FALSE){
throw("The provided equlibrium distribution: ",paste(value,collapse=" ")," is not compatible with the rate matrix! Use force=TRUE to set it anyway!\n");
}
}
# Set the value:
this$.equ.dist<-rbind(value);
# Set dimnames:
colnames(this$.equ.dist)<-(this$alphabet$symbols);
rownames(this$.equ.dist)<-c("Prob:");
return(invisible(this$.equ.dist));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .setEquDistFromGuess
##
setMethodS3(
".setEquDistFromGuess",
class="GeneralSubstitution",
function(
this,
...
){
# Try to guess equlibrium distribution:
tmp<-.guessEquDist(this);
# Take care with the condition here!
# We can get in trouble with any()
# if the first value is zero!
if( length(tmp) == 1 & all(tmp == FALSE) ){
warning("The equlibrium distribution of the substitution process could not be determined based on the rate matrix!\n You have to set yourself the proper distribution in order to use the process!");
return(FALSE);
}
else {
this$equDist<-tmp;
return(TRUE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkEquMatCompat
##
setMethodS3(
".checkEquMatCompat",
class="GeneralSubstitution",
function(
this,
value,
...
){
if(missing(value)) {
throw("No equlibrium distribution provided!\n")
}
else if ( length(value) != dim(this$.q.matrix$.orig.matrix)[[2]] ){
throw("Value vector length should be",dim(this$.q.matrix$.orig.matrix)[[2]],"!\n");
}
else {
# The following matrix product of the equlibrium distribution
# and the rate matrix should give the zero vector:
tmp<-(rbind(value) %*% as.matrix(this$.q.matrix$.orig.matrix));
if(PSRoot$my.all.equal(tmp, rep(0.0, times=length(tmp))) ){
return(invisible(TRUE));
} else {
return(FALSE);
}
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .guessEquDist
##
setMethodS3(
".guessEquDist",
class="GeneralSubstitution",
function(
this,
...
){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot guess equilibrium distribution because the Q matrix is not set!\n");
}
# Refuse to guess if the rate matrix has zero entries:
if(length(which(this$.q.matrix$.orig.matrix == 0)) != 0 ){
warning("Cannot guess equilibrium distribution because the rate matrix has zero entries!\n");
return(FALSE);
}
# Get the left eigenvalues and eigenvectors of the rate matrix:
eigen<-eigen(t(this$.q.matrix$.orig.matrix));
dist<-numeric(0);
if( length(intersect(is.complex(eigen$values),TRUE)) == 0 ) {
# if all eigenvalues are real:
# Choose the largest eigenvalue (which should be zero):
index<-which( eigen$values == max(eigen$values));
# Choose the correspondign eigenvector:
dist<-rbind(eigen$vectors[ ,index]);
}
else {
# If we have complex eigenvalues:
# Choose the eigenvalue (l) with maximum |e^(l)|
tmp<-abs(exp(eigen$values));
index<-which(tmp == max(tmp));
# ... and the corresponding eigenvector:
dist<-as.double(eigen$vectors[,index]);
}
# Normalize the eigenvector:
return(dist/sum(dist));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .initEquDist
##
setMethodS3(
".initEquDist",
class="GeneralSubstitution",
function(
this,
dummy=NA, # to satisfy method classification
...
){
if(!isEmpty(this$.alphabet)){
# Fill in with NA-s
this$.equ.dist<-rbind(rep(NA,times=this$.alphabet$size));
# Set the dimnames:
colnames(this$.equ.dist)<-this$.alphabet$symbols;
rownames(this$.equ.dist)<-c("Prob:");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEquDist
##
###########################################################################/**
#
# @RdocMethod getEquDist
#
# @title "Get the equilibrium distribution from a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{dummy}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# The new equlibrium distribution (invisible).
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(
# alphabet=BinaryAlphabet(),
# rate.list=list("1->0"=1,"0->1"=1)
# )
# # get equlibrium distribution
# getEquDist(p)
# # get equilibrium distribution via virtual field
# p$equDist
# # re-set the equilibrium distribution
# dist<-p$equDist * 3
# dist
# setEquDist(p,dist)
# p$equDist
# # re-set equilibrium distribution via virtual field
# p$equDist<-p$equDist * 2
# p$equDist
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEquDist",
class="GeneralSubstitution",
function(
this,
dummy=NA, # to satisfy method classification
...
){
this$.equ.dist;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: sampleState
##
###########################################################################/**
#
# @RdocMethod sampleState
#
# @title "Sample a state from the equlibrium distribution of a GeneralSubstitution object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # get equlibrium distribution
# getEquDist(p)
# # get equilibrium distribution via virtual field
# p$equDist
# # sample from equilibrium distribution
# sampleState(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"sampleState",
class="GeneralSubstitution",
function(
this,
...
){
if(!exists(x="PSIM_FAST")){
if(any(is.na(this$.equ.dist))){
throw("Cannot sample state because the equlibrium distribution is not defined!\n");
}
else if (!is.Alphabet(this$.alphabet)){
throw("Cannot sample state because the alphabet is not valid! That is strange as equlibrium distribution is defined!\n");
}
}
if(this$.alphabet$size == 0){
throw("The process alphabet is empty, nothing to sample here!\n");
}
if(this$.alphabet$size == 1){
# Special case: single letter in the alphabet:
return(this$.alphabet$symbols[[1]]);
}
else {
# Sample from the equlibrium distribution:
sample(x=this$.alphabet$.symbols, size=1, replace=FALSE, prob=this$.equ.dist);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getQMatrix
##
###########################################################################/**
#
# @RdocMethod getQMatrix
#
# @title "Get the QMatrix object aggregated by a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# This method is mostly used internally.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# A QMatrix object.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # get the QMatrix object
# getQMatrix(p)
# # get the QMatrix object via virtual field
# q<-p$qMatrix
# # tweak with the QMatrix
# setRate(q,"0->1",2)
# # set a new QMatrix for p
# setQMatrix(p,q)
# summary(p)
# # set new QMatrix via virtual field
# setRate(q,"1->0",2)
# p$qMatrix<-q
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getQMatrix",
class="GeneralSubstitution",
function(
this,
...
){
this$.q.matrix;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setQMatrix
##
###########################################################################/**
#
# @RdocMethod setQMatrix
#
# @title "Set the QMatrix object aggregated by a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# This method is mostly used internally.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{value}{A QMatrix object.}
# \item{...}{Not used.}
# }
#
# \value{
# The QMatrix object.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # get the QMatrix object
# getQMatrix(p)
# # get the QMatrix object via virtual field
# q<-p$qMatrix
# # tweak with the QMatrix
# setRate(q,"0->1",2)
# # set a new QMatrix for p
# setQMatrix(p,q)
# summary(p)
# # set new QMatrix via virtual field
# setRate(q,"1->0",2)
# p$qMatrix<-q
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setQMatrix",
class="GeneralSubstitution",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)){
throw("No new value provided!\n");
}
else if(!is.QMatrix(value)){
throw("The provided object is not a QMatrix!\n");
}
else if (!is.Alphabet(getAlphabet(this))){
throw("Cannot set QMatrix because process alphabet is not defined!\n");
}
else if(!is.Alphabet(value$alphabet)){
throw("Cannot set QMatrix because the alphabet of the provided QMatrix object is not set!\n");
}
else if(getAlphabet(this) != value$alphabet){
throw("Alphabet mismatch! Cannot set QMatrix!\n");
}
}
this$.q.matrix<-value;
return(this$.q.matrix)
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setAlphabet
##
###########################################################################/**
#
# @RdocMethod setAlphabet
#
# @title "Set the Alphabet object aggregated by a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# This method also sets the alphabet for the associated QMatrix object, which will set all rates to NA.
# This method will also re-initialize the equlibrium distribution by setting all frequencies to NA.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{value}{An Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# The Alphabet object.
# }
#
# \examples{
# # create a GeneralSubstitution object with an attached BinaryAlphabet object
# p<-GeneralSubstitution(alphabet=BinaryAlphabet())
# # get object summary
# summary(p)
# # get alphabet
# getAlphabet(p)
# # get alphabet via virtual field
# p$alphabet
# # set a new alphabet
# setAlphabet(p,NucleotideAlphabet())
# summary(p)
# # set alphabet via virtual field
# p$alphabet<-BinaryAlphabet()
# p$alphabet
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setAlphabet",
class="GeneralSubstitution",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)){
throw("No new value provided!\n");
}
else if (!is.Alphabet(value)){
throw("Alphabet object is invalid!\n");
}
}
this$.alphabet<-value;
# Set the QMatrix alphabet
if(is.QMatrix(this$.q.matrix)){
setAlphabet(this$.q.matrix, value);
}
.initEquDist(this);
return(this$.alphabet);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAlphabet
##
###########################################################################/**
#
# @RdocMethod getAlphabet
#
# @title "Get the Alphabet object aggregated by a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# This method also sets the alphabet for the associated QMatrix object, which will set all rates to NA.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# An Alphabet object.
# }
#
# \examples{
# # create a GeneralSubstitution object with an attached BinaryAlphabet object
# p<-GeneralSubstitution(alphabet=BinaryAlphabet())
# # get object summary
# summary(p)
# # get alphabet
# getAlphabet(p)
# # get alphabet via virtual field
# p$alphabet
# # set a new alphabet
# setAlphabet(p,NucleotideAlphabet())
# summary(p)
# # set alphabet via virtual field
# p$alphabet<-BinaryAlphabet()
# p$alphabet
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAlphabet",
class="GeneralSubstitution",
function(
this,
...
){
# Just to satisfy method classification:
this$.alphabet;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: hasUndefinedRate
##
###########################################################################/**
#
# @RdocMethod hasUndefinedRate
#
# @title "Check if a GeneralSubstitution object has undefined rates"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create a GeneralSubstitution object
# p<-GeneralSubstitution(alphabet=BinaryAlphabet())
# # check if it has undefined rates
# hasUndefinedRate(p) # TRUE
# # set the missing rates
# p$rateList<-list("0->1"=1,"1->0"=2)
# # check for undefined rates again
# hasUndefinedRate(p) # FALSE
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"hasUndefinedRate",
class="GeneralSubstitution",
function(
this,
...
){
if( any(is.na(this$.q.matrix$.orig.matrix)) | any(is.na(this$.q.matrix$.rate.matrix))){
return(TRUE);
}
else {
return(FALSE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventRate
##
###########################################################################/**
#
# @RdocMethod getEventRate
#
# @title "Get the scaled rate of an event from a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# This method return the element from the scaled rate matrix stored in the associated QMatrix object corresponding to
# a given event. The event can be specified by the inital and target states ("from" and "to" arguments), or by the
# event name ("from->to"). The event name takes precedence over the "from" and "to" arguments.
#
# This method doesn't take into account the site specific rate multipliers in any way.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{name}{The name of the event.}
# \item{from}{The initial state.}
# \item{to}{Target state.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # get the scaled rate of "0->1" by name
# getEventRate(p,"0->1")
# # get the scaled rate of "0->1" by states
# getEventRate(p,from="0",to="1")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEventRate",
class="GeneralSubstitution",
function(
this,
name=NA,
from=NA,
to=NA,
...
){
# For getting the scaled event rate:
if(!exists(x="PSIM_FAST")){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot get rate as the rate matrix is undefined!\n");
}
}
else if(!missing(name) & missing(from) & missing(to)){
return(getEventRate(this$.q.matrix, name=name));
}
else if (missing(name) & !missing(from) & !missing(to)){
return(getEventRate(this$.q.matrix, from=from, to=to));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventRateAtSite
##
###########################################################################/**
#
# @RdocMethod getEventRateAtSite
#
# @title "Get the site spcific rate of an event from a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# This method return the element from the associated QMatrix object corresponding to
# a given event multiplied by the "rate.multiplier" site-process specific parameter stored in the specified site object.
# The event can be specified by the inital and target states ("from" and "to" arguments), or by the
# event name ("from->to"). The event name takes precedence over the "from" and "to" arguments.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object. It must be attached to the provided Site object.}
# \item{site}{A Site object.}
# \item{name}{The name of the event.}
# \item{from}{The initial state.}
# \item{to}{Target state.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # create a Site object
# s<-Site(alphabet=BinaryAlphabet())
# # attach process p to site s
# s$processes<-list(p)
# # set the rate multiplier for s and p
# setParameterAtSite(p,s,id="rate.multiplier",value=2)
# # get the site specific rate of "0->1" by name
# getEventRateAtSite(p,s,"0->1")
# # get the site specific rate of "0->1" by states
# getEventRateAtSite(p,s,from="0",to="1")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEventRateAtSite",
class="GeneralSubstitution",
function(
this,
site,
name=NA,
from=NA,
to=NA,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(site)){
throw("No site provided");
}
else if (!isAttached(site, process=this)){
throw("The process is not attached to the specified site!\n");
}
}
global.rate<-numeric();
# Event specified by name:
if(!missing(name) & missing(from) & missing(to)){
global.rate<-getEventRate(this$.q.matrix, name=name);
}
# Event specified by from= and to=
else if(missing(name) & !missing(from) & !missing(to)){
global.rate<-getEventRate(this$.q.matrix, from=from, to=to);
}
else {
throw("The substitution should be specified by name or by the \"from\" and \"to\" arguments!\n");
}
return(global.rate * site$.processes[[this$.id]]$site.params[["rate.multiplier"]]$value );
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRate
##
###########################################################################/**
#
# @RdocMethod getRate
#
# @title "Get an unscaled rate of an event from a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# This method gets the element corresponding to a given event form the unscaled Q matrix.
# a given event. The event can be specified by the inital and target states ("from" and "to" arguments), or by the
# event name ("from->to"). The event name takes precedence over the "from" and "to" arguments.
#
# The rescaled rates (used during simulations) are returned by the \code{getEventRate} method.
#
# This method doesn't take into account the site specific rate multipliers in any way.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{name}{The name of the event.}
# \item{from}{The initial state.}
# \item{to}{Target state.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # get the unscaled rate of "0->1" by name
# getRate(p,"0->1")
# # get the unscaled rate of "0->1" by states
# getRate(p,from="0",to="1")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRate",
class="GeneralSubstitution",
function(
this,
name=NA,
from=NA,
to=NA,
...
){
if(!exists(x="PSIM_FAST")){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot get rate as the rate matrix is undefined!\n");
}
}
if(!missing(name) & missing(from) & missing(to)){
return(getRate(this$.q.matrix, name=name));
}
else if (missing(name) & !missing(from) & !missing(to)){
return(getRate(this$.q.matrix, from=from, to=to));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRate
##
###########################################################################/**
#
# @RdocMethod setRate
#
# @title "Set an unscaled rate for an event from a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# This method sets the element corresponding to a given event in the unscaled Q matrix.
# The event can be specified by the inital and target states ("from" and "to" arguments), or by the
# event name ("from->to"). The event name takes precedence over the "from" and "to" arguments.
#
# Modifying any rate in the unscaled Q matrix will trigger the re-scaling of the whole matrix.
# The rescaled rates (used during simulations) are returned by the \code{getEventRate} method.
#
# This method doesn't modify the site specific rate multipliers.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{name}{The name of the event.}
# \item{from}{The initial state.}
# \item{value}{The new value of the rate.}
# \item{to}{Target state.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # set the unscaled rate by event name
# setRate(p,"0->1",2)
# # get the unscaled rate of "0->1" by name
# getRate(p,"0->1")
# # set the unscaled rate by states
# setRate(p,"0->1",0.5)
# # get the unscaled rate of "0->1" by states
# getRate(p,from="0",to="1")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRate",
class="GeneralSubstitution",
function(
this,
name=NA,
value,
from=NA,
to=NA,
...
){
.checkWriteProtection(this);
# Setting unscaled rate:
if(!exists(x="PSIM_FAST")){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot set rate as the rate matrix is undefined!\n");
}
}
if(!missing(name) & missing(from) & missing(to)){
return(setRate(this$.q.matrix, name=name, value=value));
}
else if (missing(name) & !missing(from) & !missing(to)){
return(setRate(this$.q.matrix, from=from, to=to, value=value));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateList
##
###########################################################################/**
#
# @RdocMethod getRateList
#
# @title "Get a list of events and their unscaled rates from a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# This method returns the list of event rates from the \emph{unscaled} Q matrix (as returbed bvy the \code{getEventRate} method).
# The returned list contains the rates associated with the corresponding event names.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of event rates.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=3))
# # get the event rates from the unscaled Q matrix
# getRateList(p)
# # get rates from the unscaled rate matrix via virtual field
# p$rateList
# # set rates in the unscaled rate matrix
# setRateList(p, list("0->1"=1,"1->0"=1))
# p$rateList
# # set rates in the unscaled rate matrix via virtual field
# p$rateList<-list("0->1"=3,"1->0"=1);
# # check the contenst of the associated QMatrix object
# summary(p$QMatrix)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateList",
class="GeneralSubstitution",
function(
this,
...
){
if(!exists(x="PSIM_FAST")){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot get rate list as the rate matrix is undefined!\n");
}
}
return(getRateList(this$.q.matrix));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateList
##
###########################################################################/**
#
# @RdocMethod setRateList
#
# @title "Setting the rates for a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# This method set the rates in the \emph{unscaled} Q matrix based on the provided list containing even names
# and the associated rates. The rate must be specified for every event!
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{value}{A list with the events names and the associated rates.}
# \item{...}{Not used.}
# }
#
# \value{
# The GeneralSubstitution object (invisible).
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=3))
# # get the event rates from the unscaled Q matrix
# getRateList(p)
# # get rates from the unscaled rate matrix via virtual field
# p$rateList
# # set rates in the unscaled rate matrix
# setRateList(p, list("0->1"=1,"1->0"=1))
# p$rateList
# # set rates in the unscaled rate matrix via virtual field
# p$rateList<-list("0->1"=3,"1->0"=1);
# # check the contenst of the associated QMatrix object
# summary(p$QMatrix)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateList",
class="GeneralSubstitution",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot get rate list as the rate matrix is undefined!\n");
}
else if(missing(value)){
throw("No new rate list specified!\n");
}
}
return(setRateList(this$.q.matrix, value) );
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: rescaleQMatrix
##
###########################################################################/**
#
# @RdocMethod rescaleQMatrix
#
# @title "Rescale the scaled rate matrix of a QMatrix object aggregated by a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# The QMatrix objects aggregated by the GeneralSubstitution objects store two rate matrices: one containes
# the rates provided by the user (unscaled rate matrix), the other matrix (scaled rate matrix) is rescaled to have the
# expected number of subsitutions per unit time equal to one when the process is at equlibrium.
# This method performes the re-scaling of the scaled rate matrix in the associated QMatrix object based on
# the equlibrium distribution and the unscaled rate matrix.
#
# This method is mainly used internally as the scaled matrix is rescaled every time the unscaled matrix
# is modifed.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=3))
# # rescale rate matrix
# rescaleQMatrix(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"rescaleQMatrix",
class="GeneralSubstitution",
function(
this,
...
){
if(!exists(x="PSIM_FAST")){
if(is.na(this$.q.matrix)){
return(invisible(FALSE));
}
else if(!is.QMatrix(this$.q.matrix)){
throw("Cannot rescale rate matrix because it is invalid!\n");
}
else if (any(is.na(this$.q.matrix))){
throw("Cannot rescale rate matrix because not all rates are specified!\n");
}
else if(any(is.na(this$.equ.dist))){
throw("Cannot rescale rate matrix because the equlibrium distribution is not defined properly!\n");
}
# Check for alphabet mismatch:
if(this$alphabet != this$.q.matrix$.alphabet){
throw("The process alphabet and the QMatrix alphabet is not the same! Refusing to rescale!\n");
}
}
# Set rescaling constant to zero:
K <- 0;
# get the symbols:
symbols<-this$alphabet$symbols;
orig.matrix<-this$.q.matrix$.orig.matrix;
# For every symbol:
for (i in symbols) {
# Get the equlibrium probability:
i.equ<-this$.equ.dist[[ which(colnames(this$.equ.dist) == i) ]];
for(j in symbols){
if(i == j){next}
# For every other symbol - update the constant:
K <- K + (i.equ * orig.matrix[i,j] );
}
}
Scale(this$.q.matrix,constant=(1/K));
# After rescaling the expected rate of substitutions per site
# at equlibrium is 1.
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: is.GeneralSubstitution
##
###########################################################################/**
#
# @RdocDefault is.GeneralSubstitution
#
# @title "Check if an object is an instance of the GeneralSubstitution class"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create some objects
# p<-GeneralSubstitution()
# pp<-Process()
# # chek if they inherit from GeneralSubstitution
# is.GeneralSubstitution(p)
# is.GeneralSubstitution(pp)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"is.GeneralSubstitution",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.general.substitution)){return(TRUE)}
if ( inherits(this, "GeneralSubstitution")) {
this$.is.general.substitution<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: as.character
##
###########################################################################/**
#
# @RdocMethod as.character
#
# @title "Return the character representation of a GeneralSubstitution object"
#
# \description{
# @get "title".
# The character representation is the object id as returned by the
# \code{getId.Process} method defined in the parent class.
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A GeneralSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a GeneralSubstitution object
# p<-GeneralSubstitution(name="MySubst")
# # get character representation
# as.character(p)
# # the same implicitly
# p
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"as.character",
class="GeneralSubstitution",
function(
x,
...
){
x$.id;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-GeneralSubstitution(alphabet=BinaryAlphabet(),rate.list=list("0->1"=1,"1->0"=2))
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="GeneralSubstitution",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
.addSummaryAlphabet(this);
if(is.null(this$.summary$"Unscaled rate matrix")){
this$.summary$"Unscaled rate matrix"<-paste( "\n\t",paste(capture.output(print(this$.q.matrix)),collapse="\n\t"),"\n",sep="");
}
this$.summary$"Equilibrium distribution"<-paste( "\n\t",paste(capture.output(print(this$.equ.dist)),collapse="\n\t"),"\n",sep="");
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: clone
##
###########################################################################/**
#
# @RdocMethod clone
#
# @title "Clone a GeneralSubstitution object"
#
# \description{
# @get "title".
#
# This method also clones the aggregated QMatrix object, but not the aggregated Alphabet
# object, as that is a good target for recycling.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# A GeneralSubstitution object.
# }
#
# \examples{
# # create a GeneralSubstitution object
# p<-GeneralSubstitution(
# alphabet=BinaryAlphabet(),
# rate.list=list("0->1"=1,"1->0"=2),
# name="MyBinary"
# )
# # clone p
# pp<-clone(p)
# # do some checks
# p;pp
# p == p
# p == pp
# equals(p$qMatrix, pp$qMatrix)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"clone",
class="GeneralSubstitution",
function(
this,
...
){
# Clone the process object:
that<-clone.Object(this);
# Disable write protection:
if(that$writeProtected){
that$writeProtected<-FALSE;
}
# Clone Q matrix object:
that$.q.matrix<-clone(this$.q.matrix);
that$.q.matrix$.process<-that;
# Reassingning name to force Id update:
that$name<-that$name;
return(that);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: plot
##
###########################################################################/**
#
# @RdocMethod plot
#
# @title "Create a bubble plot of the substitution process"
#
# \description{
# @get "title".
#
# Bubble plots visualize the characteristics of the
# substitution process. The area of the circles is proportional to the rates/probabilities.
# The plot is not produced if the rate matrix or the equlibrium
# distribution has undefined elements.
# }
#
# @synopsis
#
# \arguments{
# \item{x}{An object inheriting from GeneralSubstitution.}
# \item{scale}{A scale factor affecting the area of the circles.}
# \item{...}{Not used.}
# }
#
# \value{
# The process object (invisible).
# }
#
# \examples{
# plot(BinarySubst(rate.list=list("0->1"=1,"1->0"=1.5)))
# plot(JC69())
# # get smaller circles
# plot(JC69(),scale=0.5)
# plot(F84(base.freqs=c(3/6,1/6,1/6,1/6)))
# plot(WAG())
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"plot",
class="GeneralSubstitution",
function(
x,
scale=1,
...
){
if(!is.numeric(scale)){
throw("Scale parameter must be numeric!");
}
if(scale <= 0){
throw("Scale parameter must be positive!");
}
if(hasUndefinedRate(x)) {
throw("Cannot plot process: the rate matrix has undefined elements!");
}
if(any(is.na(x$equDist))) {
throw("Cannot plot process: the equilibrium distribution has undefined elements!");
}
qmat<-x$.q.matrix$scaledMatrix;
# setting up viewports
point_scale<-40.0;
grid.newpage();
size<-dim(qmat)[1];
dsize<-(max(c(1/size,( (0.23 * size - 0.65)/size ) )));
layout<-grid.layout(nrow=2,ncol=1,heights=c((1 - dsize), dsize),respect=TRUE);
vp1<-viewport(layout=layout,layout.pos.row=1,layout.pos.col=1);
vp2<-viewport(layout=layout,layout.pos.row=2,layout.pos.col=1);
pushViewport(vp1);
# tabulate rates
xx<-c();
yy<-c();
zz<-c();
for(cl in (colnames(qmat))){
for(rw in (rownames(qmat))){
if(rw != cl){
xx<-c(xx,cl)
yy<-c(yy,rw)
zz<-c(zz,qmat[as.character(rw), as.character(cl)]);
}
}
}
# visual aspect tuned by "magic" formulas :)
my.plot<-(qplot(x=xx,y=yy,size=zz,xlab="To:",ylab="From:",main="Rate matrix") + geom_point(colour="blue") +
scale_size_area(limits=c(0,max(zz)), name="Size:")
) + xlim(colnames(qmat)) + ylim(rev(rownames(qmat)));
print(my.plot, vp=vp1);
popViewport(1);
# equlibrium distribution
dist<-x$equDist;
xx<-c();
yy<-c();
zz<-c();
for(cl in colnames(dist)){
xx<-c(xx, cl);
yy<-c(yy, 1);
zz<-c(zz,dist[1,as.character(cl)]);
}
pushViewport(vp2);
fr<-max(zz) - min(zz);
# visual aspect tuned by "magic" formulas :)
my.plot<-(qplot(x=xx,y=yy,size=zz,xlab="Symbol",ylab="Prob:",main="Equlibrium distribution") + geom_point(colour="green") +
scale_size_area(limits=c(0,max(zz)), name="Size:",breaks=c(min(zz),min(zz) + fr*(1/3),min(zz) + fr*(2/3),max(zz))) + xlim(xx)
);
print(my.plot,vp=vp2);
popViewport(1);
return(invisible(x));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass UNREST
#
# @title "The UNREST class"
#
# \description{
# This class implements the UNRESTricted nucleotide substitution model.
# UNREST objects are basically a GeneralSubstitution process acting on a
# nucleotide alphabet.
#
# @classhierarchy
# }
# \references{
# Yang, Z (1994) Estimating the pattern of nucleotide substitution - Journal of Molecular Evolution
# 39:105-111 \url{http://bit.ly/aFO0cq}
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{rate.list}{A list of unscaled rates (see \code{setRateList.GeneralSubstitution}).}
# \item{equ.dist}{Equlibrium distribution.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# p<-UNREST(rate.list=list(
# "T->C"=1, "T->A"=2, "T->G"=3, "C->T"=4, "C->A"=1,
# "C->G"=2, "A->T"=3, "A->C"=4, "A->G"=1, "G->T"=2,
# "G->C"=3, "G->A"=4
# ))
# # get a summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-NucleotideSequence(length=20,processes=list(list(p)))
# # sample states
# sampleStates(s)
# # make the first five positions invariable
# setRateMultipliers(s,p,0,1:5)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GeneralSubstitution GTR
# }
#
#*/###########################################################################
setConstructorS3(
"UNREST",
function(
name="Anonymous", # name of the object
rate.list=NA, # list of unscaled rates
equ.dist=NA, # equlibrium distribution
...
) {
got.rate.list<-!missing(rate.list);
got.equ.dist<-!missing(equ.dist);
this<-NA;
# Got rate list and equlibrium distribution:
if(got.rate.list & got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=NucleotideAlphabet(),
rate.list=rate.list,
equ.dist=equ.dist
);
this<-extend(this, "UNREST");
}
# Got rate list
else if(got.rate.list & !got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=NucleotideAlphabet(),
rate.list=rate.list
);
this<-extend(this, "UNREST");
}
# Got equlibrium distribution,
# we set it, but it will be owerwritten anyway.
else if(!got.rate.list & got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=NucleotideAlphabet(),
equ.dist=equ.dist
);
this<-extend(this, "UNREST");
}
# Got nothing:
else if(!got.rate.list & !got.equ.dist){
this<-GeneralSubstitution(
name=name,
alphabet=NucleotideAlphabet()
);
this<-extend(this, "UNREST");
}
# Force clearing id cache:
this$name<-this$name;
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="UNREST",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if(!inherits(this$alphabet, "NucleotideAlphabet")){
throw("This object must have as alphabet a NucleotideAlphabet object!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
# # create an object
# p<-UNREST(rate.list=list(
# "T->C"=1, "T->A"=2, "T->G"=3, "C->T"=4, "C->A"=1,
# "C->G"=2, "A->T"=3, "A->C"=4, "A->G"=1, "G->T"=2,
# "G->C"=3, "G->A"=4
# ))
# # get a summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="UNREST",
function(
object,
...
){
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Constructor: JC69
##
##########################################################################/**
#
# @RdocClass JC69
#
# @title "The JC69 class"
#
# \description{
# This class implements Jukes-Cantor nucleotide substitution model.
#
# @classhierarchy
# }
#
# \references{
# Jukes, TH and Cantor, CR (1969) Evolution of protein molecules. Pp. 21-123 in H. N. Munro,
# ed. Mammalian protein metabolism. Academic Press, New York.
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# p<-JC69()
# # get a summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-NucleotideSequence(length=20,processes=list(list(p)))
# # sample states
# sampleStates(s)
# # make the first five positions invariable
# setRateMultipliers(s,p,0,1:5)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GeneralSubstitution UNREST GTR
# }
#
#*/###########################################################################
setConstructorS3(
"JC69",
function(
name="Anonymous", # object name
...
) {
# Set all rates to be equal.
this<-UNREST(rate.list=list(
"A->T"=1,
"A->C"=1,
"A->G"=1,
"T->A"=1,
"T->C"=1,
"T->G"=1,
"C->A"=1,
"C->T"=1,
"C->G"=1,
"G->A"=1,
"G->T"=1,
"G->C"=1
));
this<-extend(this,"JC69");
this$name<-name;
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="JC69",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
qmat<-this$.q.matrix$Matrix;
# This is a dumb method to check the sanity of the rates, but consistency checking
# should not be called frequently.
diag(qmat)<-1;
if(any(qmat != 1)){
throw("The unscaled rate matrix is not consistent with the JC69 model!\n");
}
if ( !all.equal(as.numeric(this$.equ.dist), as.numeric(rep(0.25,times=4)) ) ){
throw("The equlibrium distribution of the JC69 model should be uniform!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
# # create an object
# p<-JC69()
# # get a summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="JC69",
function(
object,
...
){
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
#
# Constructor: GTR
#
##########################################################################/**
#
# @RdocClass GTR
#
# @title "The GTR class"
#
# \description{
# This class implements the general time-reversible nucleotide substitution model (GTR, REV).
# The rate parameters are named as in PAML (see PAML documentation: \url{http://bit.ly/9SQK2f}).
#
# The default value for the rate parameters is 1 and the default value for the base
# frequencies is 0.25. So the GTR objects are equivalent to JC69 objects by default.
#
# @classhierarchy
# }
# \references{
# Tavare, S (1986) "Some Probabilistic and Statistical Problems in the Analysis of DNA Sequences".
# American Mathematical Society: Lectures on Mathematics in the Life Sciences 17:57-86
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{rate.params}{A list of unscaled rates (see \code{setRateList.GeneralSubstitution}).}
# \item{base.freqs}{Equlibrium distribution.}
# \item{...}{Additional arguments.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution process object
# p<-GTR(
# rate.params=list(
# "a"=1, "b"=2, "c"=3,
# "d"=1, "e"=2, "f"=3
# ),
# base.freqs=c(2,2,1,1)/6
# )
# # get a summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-NucleotideSequence(length=20,processes=list(list(p)))
# # sample states
# sampleStates(s)
# # make the first five positions invariable
# setRateMultipliers(s,p,0,1:5)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object and run simulation
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GeneralSubstitution UNREST HKY
# }
#
#*/###########################################################################
setConstructorS3(
"GTR",
function(
name="Anonymous",
# The GTR rate parameters:
rate.params=list(
"a"=1,
"b"=1,
"c"=1,
"d"=1,
"e"=1,
"f"=1
),
# Base frequencies (equlibrium distribution):
base.freqs=rep(0.25,times=4),
...
) {
this<-UNREST();
this<-extend(
this,
"GTR",
.gtr.params=list(
"a"=NA,
"b"=NA,
"c"=NA,
"d"=NA,
"e"=NA,
"f"=NA
)
);
this$name<-name;
setEquDist(this,value=base.freqs,force=TRUE)
setRateParamList(this,value=rate.params);
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="GTR",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# All rate parameters should be positive:
if (any( as.numeric(this$.gtr.params) < 0 ) ){
throw("Found negative GTR rate parameters!\n");
}
else {
rates<-this$.q.matrix$Matrix;
if (
!PSRoot$my.all.equal( rates[["T","C"]] , (this$.gtr.params[["a"]] * this$.equ.dist[1,"C"] ) )|
!PSRoot$my.all.equal( rates[["C","T"]] , (this$.gtr.params[["a"]] * this$.equ.dist[1,"T"] ) )|
!PSRoot$my.all.equal( rates[["T","A"]] , (this$.gtr.params[["b"]] * this$.equ.dist[1,"A"] ) )|
!PSRoot$my.all.equal( rates[["A","T"]] , (this$.gtr.params[["b"]] * this$.equ.dist[1,"T"] ) )|
!PSRoot$my.all.equal( rates[["T","G"]] , (this$.gtr.params[["c"]] * this$.equ.dist[1,"G"] ) )|
!PSRoot$my.all.equal( rates[["G","T"]] , (this$.gtr.params[["c"]] * this$.equ.dist[1,"T"] ) )|
!PSRoot$my.all.equal( rates[["C","A"]] , (this$.gtr.params[["d"]] * this$.equ.dist[1,"A"] ) )|
!PSRoot$my.all.equal( rates[["A","C"]] , (this$.gtr.params[["d"]] * this$.equ.dist[1,"C"] ) )|
!PSRoot$my.all.equal( rates[["C","G"]] , (this$.gtr.params[["e"]] * this$.equ.dist[1,"G"] ) )|
!PSRoot$my.all.equal( rates[["G","C"]] , (this$.gtr.params[["e"]] * this$.equ.dist[1,"C"] ) )|
!PSRoot$my.all.equal( rates[["A","G"]] , (this$.gtr.params[["f"]] * this$.equ.dist[1,"G"] ) )|
!PSRoot$my.all.equal( rates[["G","A"]] , (this$.gtr.params[["f"]] * this$.equ.dist[1,"A"] ) )
) {
throw("Rate matrix is not consistent with the GTR rate parameters!\n");
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .getRateParam
##
setMethodS3(
".getRateParam",
class="GTR",
function(
this,
name,
param.list,
...
){
if(length(intersect(name,names(param.list))) == 0){
throw("The specified rate parameter name is not valid!\n");
}
else {
return(param.list[[name]]);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateParam
##
###########################################################################/**
#
# @RdocMethod getRateParam
#
# @title "Get the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are named as in PAML (see PAML documentation: \url{http://bit.ly/9SQK2f}).
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GTR object.}
# \item{name}{The name of the rate parameter.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # construct a GTR object
# p<-GTR();
# # set/get a rate parameter
# setRateParam(p,"a",4)
# getRateParam(p,"a")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParam",
class="GTR",
function(
this,
name,
...
){
if(missing(name)){
throw("No rate parameter name specified!\n");
}
else {
.getRateParam(this,name,this$.gtr.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .setRateParam
##
setMethodS3(
".setRateParam",
class="GTR",
function(
this,
name,
value,
param.list,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(length(intersect(name,names(param.list))) == 0){
throw("The specified rate parameter name is not valid!\n");
}
else if(missing(value)){
throw("No new value given!\n")
}
else if(length(value) != 1|any(!is.numeric(value))){
throw("The new value must be a numeric vector of length 1!\n");
}
else if(any(is.na(this$.equ.dist))){
throw("Cannot set rate parameter because the nucleotide frequencies are not defined properly!\n");
}
}
param.list[[name]]<-value;
# We call setRateParamList to rebuild the whole rate
# matrix with the new values if one of the rates changed:
setRateParamList(this, param.list);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParam
##
###########################################################################/**
#
# @RdocMethod setRateParam
#
# @title "Set the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are named as in PAML (see PAML documentation: \url{http://bit.ly/9SQK2f}).
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GTR object.}
# \item{name}{The name of the rate parameter.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of the rate parameter (invisible).
# }
#
# \examples{
# # construct a GTR object
# p<-GTR();
# # set/get a rate parameter
# setRateParam(p,"a",4)
# getRateParam(p,"a")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParam",
class="GTR",
function(
this,
name,
value,
...
){
.checkWriteProtection(this);
if(missing(name)){
throw("No rate parameter name specified!\n");
} else {
.setRateParam(this,name,value,this$.gtr.params);
}
return(invisible(value));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateParamList
##
###########################################################################/**
#
# @RdocMethod getRateParamList
#
# @title "Get the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are named as in PAML (see PAML documentation: \url{http://bit.ly/9SQK2f}).
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GTR object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of rate parameters.
# }
#
# \examples{
# # create GTR object
# p<-GTR()
# # set/get rate parameters
# setRateParamList(p,list(
# "a"=1, "b"=2, "c"=3,
# "d"=1, "e"=2, "f"=3
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "a"=4, "b"=1, "c"=4,
# "d"=1, "e"=4, "f"=1
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParamList",
class="GTR",
function(
this,
...
){
this$.gtr.params;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkRateParamList
##
setMethodS3(
".checkRateParamList",
class="GTR",
function(
this,
names,
value.names,
...
){
# Check for illegal rate parameter names:
if(length((illegal<-setdiff(value.names, names))) != 0){
throw("The following rate parameter names are illegal: ",paste(illegal, collapse=", ")," !\n");
}
else {
missing<-setdiff(names, value.names);
if(length(missing) > 0) {
throw("Cannot build the model because the following rate parameters are missing: ",paste(missing,collapse=", ")," \n");
} else {
return(TRUE);
}
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParamList
##
###########################################################################/**
#
# @RdocMethod setRateParamList
#
# @title "Set the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are named as in PAML (see PAML documentation: \url{http://bit.ly/9SQK2f}).
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GTR object.}
# \item{value}{A list containing the rate parameters.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters (invisible).
# }
#
# \examples{
# # create GTR object
# p<-GTR()
# # set/get rate parameters
# setRateParamList(p,list(
# "a"=1, "b"=2, "c"=3,
# "d"=1, "e"=2, "f"=3
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "a"=4, "b"=1, "c"=4,
# "d"=1, "e"=4, "f"=1
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParamList",
class="GTR",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)){
throw("No new value provided!\n");
}
else if(!is.list(value)){
throw("The provided value must be a list!\n");
}
else if(any((as.numeric(value)) < 0)){
throw("Cannot set negative rate parameter!\n");
}
}
# Get the rate parameter names:
names<-names(this$.gtr.params);
value.names<-names(value);
if(.checkRateParamList(this,names,value.names)) {
# Set the rate parameters:
# The parmeters are named as in
# "Ziheng Yang: Computational Molecular Evolution,
# Oxford university Press, Oxford, 2006", pp. 34.
rate.list=list(
"T->C"=(value[["a"]] * this$.equ.dist[1,"C"] ),
"C->T"=(value[["a"]] * this$.equ.dist[1,"T"] ),
"T->A"=(value[["b"]] * this$.equ.dist[1,"A"] ),
"A->T"=(value[["b"]] * this$.equ.dist[1,"T"] ),
"T->G"=(value[["c"]] * this$.equ.dist[1,"G"] ),
"G->T"=(value[["c"]] * this$.equ.dist[1,"T"] ),
"C->A"=(value[["d"]] * this$.equ.dist[1,"A"] ),
# Can you spot the pattern here: "A->C" .* "d" .* "c" :)
"A->C"=(value[["d"]] * this$.equ.dist[1,"C"] ),
"C->G"=(value[["e"]] * this$.equ.dist[1,"G"] ),
"G->C"=(value[["e"]] * this$.equ.dist[1,"C"] ),
"A->G"=(value[["f"]] * this$.equ.dist[1,"G"] ),
"G->A"=(value[["f"]] * this$.equ.dist[1,"A"] )
);
# Setting the parameter field:
this$.gtr.params<-value;
# Calling setRateList, which will set the
# elements of the rate matrix.
setRateList(this,rate.list);
}
return(invisible(value));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getBaseFreqs
##
###########################################################################/**
#
# @RdocMethod getBaseFreqs
#
# @title "Get the base frequency parameters"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GTR object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix containing the base frequencies.
# }
#
# \examples{
# # construct a GTR object
# p<-GTR()
# # set/get base frequency parameters
# setBaseFreqs(p,c(2,1,2,1)/6)
# getBaseFreqs(p)
# # set/get base frequency parameters via virtual field
# p$baseFreqs<-c(4,4,1,1)/10
# p$baseFreqs
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getBaseFreqs",
class="GTR",
function(
this,
...
){
# Its just the .equ.dist field from UNREST.
this$.equ.dist;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setBaseFreqs
##
###########################################################################/**
#
# @RdocMethod setBaseFreqs
#
# @title "Set the base frequency parameters"
#
# \description{
# @get "title".
#
# The order of the frequency parameters must match with the order of symbols
# in the NucleotideAlphabet objects.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GTR object.}
# \item{value}{A vector of base frequencies.}
# \item{...}{Not used.}
# }
#
# \value{
# value (invisible)
# }
#
# \examples{
# # construct a GTR object
# p<-GTR()
# # set/get base frequency parameters
# setBaseFreqs(p,c(2,1,2,1)/6)
# getBaseFreqs(p)
# # set/get base frequency parameters via virtual field
# p$baseFreqs<-c(4,4,1,1)/10
# p$baseFreqs
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setBaseFreqs",
class="GTR",
function(
this,
value,
...
){
.checkWriteProtection(this);
setEquDist(this,value,force=TRUE);
setRateParamList.GTR(this,value=this$.gtr.params);
return(invisible(value));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.GTR
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-GTR()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="GTR",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
.addSummaryAlphabet(this);
if (class(this)[[1]] == "GTR") {
this$.summary$"Rate parameters"<-paste(names(this$.gtr.params),this$.gtr.params,sep=" = ",collapse=", ");
}
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
######### end of GTR methods ############
##
## Constructor: TN93
##
## Tamura, K., and M. Nei. 1993. Estimation of the number of nucleotide substitutions
## in the control region of mitochondrial DNA in humans and chimpanzees.
## Molecular Biology and Evolution 10:512-526.
##
##########################################################################/**
#
# @RdocClass TN93
#
# @title "The TN93 class"
#
# \description{
# This class implements the Tamura-Nei 93 GTR-submodel.
#
# The rate parameters are the following: "Alpha1", "Alpha2","Beta".
# @classhierarchy
# }
# \references{
# Tamura, K, and Nei, M (1993) Estimation of the number of nucleotide substitutions
# in the control region of mitochondrial DNA in humans and chimpanzees -
# Molecular Biology and Evolution 10:512-526 \url{http://bit.ly/bNkCqn}
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{rate.params}{Rate parameters.}
# \item{base.freqs}{Base frequency parameters.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution process object
# p<-TN93(rate.params=list( "Alpha1"=4,"Alpha2"=3,"Beta"=2),
# base.freqs=c(2,2,1,3)/9
# )
# # get a summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-NucleotideSequence(length=20,processes=list(list(p)))
# # sample states
# sampleStates(s)
# # make the first five positions invariable
# setRateMultipliers(s,p,0,1:5)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GTR HKY UNREST GeneralSubstitution
# }
#
#*/###########################################################################
setConstructorS3(
"TN93",
function(
name="Anonymous",
rate.params=list(
"Alpha1" =1,
"Alpha2" =1,
"Beta" =1
),
base.freqs=c(0.25,0.25,0.25,0.25),
...
) {
this<-GTR();
this<-extend(
this,
"TN93",
.tn93.params=list(
"Alpha1" =NA,
"Alpha2" =NA,
"Beta" =NA
)
);
this$name<-name;
this$baseFreqs<-base.freqs;
this$rateParamList<-rate.params;
return(this);
},
enforceRCC=TRUE
);
##
## Method: getRateParamList
##
###########################################################################/**
#
# @RdocMethod getRateParamList
#
# @title "Get the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha1, Alpha2, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A TN93 object.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters.
# }
#
# \examples{
# # create TN93 object
# p<-TN93()
# # set/get rate parameters
# setRateParamList(p,list(
# "Alpha1"=1,
# "Alpha2"=2,
# "Beta"=0.5
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "Alpha1"=1,
# "Alpha2"=1,
# "Beta"=3
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParamList",
class="TN93",
function(
this,
...
){
this$.tn93.params;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParamList
##
###########################################################################/**
#
# @RdocMethod setRateParamList
#
# @title "Set the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha1, Alpha2, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A TN93 object.}
# \item{value}{A list containing the rate parameters.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters (invisible).
# }
#
# \examples{
# # create TN93 object
# p<-TN93()
# # set/get rate parameters
# setRateParamList(p,list(
# "Alpha1"=1,
# "Alpha2"=2,
# "Beta"=0.5
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "Alpha1"=1,
# "Alpha2"=1,
# "Beta"=3
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParamList",
class="TN93",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(missing(value)){
throw("No new value provided!\n");
}
else if(!is.list(value)){
throw("The provided value must be a list!\n");
}
else if(any((as.numeric(value)) < 0)){
throw("Cannot set negative rate parameter!\n");
}
else {
# Get the rate parameter names:
names<-names(this$.tn93.params);
value.names<-names(value);
if(.checkRateParamList(this,names,value.names)) {
this$.tn93.params<-value;
# Setting the GTR rate parameters:
gtr.params<-list(
"a"=value[["Alpha1"]],
"b"=value[["Beta"]],
"c"=value[["Beta"]],
"d"=value[["Beta"]],
"e"=value[["Beta"]],
"f"=value[["Alpha2"]]
);
setRateParamList.GTR(this, value=gtr.params);
}
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateParam
##
###########################################################################/**
#
# @RdocMethod getRateParam
#
# @title "Get the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha1, Alpha2, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A TN93 object.}
# \item{name}{The name of the rate parameter.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # construct a TN93 object
# p<-TN93();
# # set/get a rate parameter
# setRateParam(p,"Beta",4)
# getRateParam(p,"Beta")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParam",
class="TN93",
function(
this,
name,
...
){
if(missing(name)){
throw("No rate parameter name specified!\n");
}
else {
.getRateParam(this,name,this$.tn93.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParam
##
###########################################################################/**
#
# @RdocMethod setRateParam
#
# @title "Set the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha1, Alpha2, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A TN93 object.}
# \item{name}{The name of the rate parameter.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of the rate parameter (invisible).
# }
#
# \examples{
# # construct a TN93 object
# p<-TN93();
# # set/get a rate parameter
# setRateParam(p,"Beta",4)
# getRateParam(p,"Beta")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParam",
class="TN93",
function(
this,
name,
value,
...
){
.checkWriteProtection(this);
if(missing(name)){
throw("No rate parameter name specified!\n");
} else {
.setRateParam(this,name,value,this$.tn93.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getBaseFreqs
##
###########################################################################/**
#
# @RdocMethod getBaseFreqs
#
# @title "Get the base frequency parameters"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A TN93 object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix containing the base frequencies.
# }
#
# \examples{
# # construct a TN93 object
# p<-TN93()
# # set/get base frequency parameters
# setBaseFreqs(p,c(2,1,2,1)/6)
# getBaseFreqs(p)
# # set/get base frequency parameters via virtual field
# p$baseFreqs<-c(4,4,1,1)/10
# p$baseFreqs
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getBaseFreqs",
class="TN93",
function(
this,
...
){
getBaseFreqs.GTR(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setBaseFreqs
##
###########################################################################/**
#
# @RdocMethod setBaseFreqs
#
# @title "Set the base frequency parameters"
#
# \description{
# @get "title".
#
# The order of the frequency parameters must match with the order of symbols
# in the NucleotideAlphabet objects.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A TN93 object.}
# \item{value}{A vector of base frequencies.}
# \item{...}{Not used.}
# }
#
# \value{
# value (invisible)
# }
#
# \examples{
# # construct a TN93 object
# p<-TN93()
# # set/get base frequency parameters
# setBaseFreqs(p,c(2,1,2,1)/6)
# getBaseFreqs(p)
# # set/get base frequency parameters via virtual field
# p$baseFreqs<-c(4,4,1,1)/10
# p$baseFreqs
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setBaseFreqs",
class="TN93",
function(
this,
value,
...
){
setBaseFreqs.GTR(this,value);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency.TN93
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="TN93",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# Rate parameters should not be negative:
if(any(this$.tn93.params < 0 )){
throw("Found negative TN93 rate parameters!\n");
}
else {
if(
this$.gtr.params[["a"]]!=this$.tn93.params[["Alpha1"]]|
this$.gtr.params[["b"]]!=this$.tn93.params[["Beta"]]|
this$.gtr.params[["c"]]!=this$.tn93.params[["Beta"]]|
this$.gtr.params[["d"]]!=this$.tn93.params[["Beta"]]|
this$.gtr.params[["e"]]!=this$.tn93.params[["Beta"]]|
this$.gtr.params[["f"]]!=this$.tn93.params[["Alpha2"]]
) {
throw("The TN93 parameters are not consistent with the GTR parameters!\n");
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.TN93
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-NucleotideAlphabet()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="TN93",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
.addSummaryAlphabet(this);
if (class(this)[[1]] == "TN93") {
this$.summary$"Rate parameters"<-paste(names(this$.tn93.params),this$.tn93.params,sep=" = ",collapse=", ");
}
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
######### end of TN93 methods ############
##
## Constructor: HKY
##
## Hasegawa, M., H. Kishino, and T. Yano. (1985) Dating of human-ape splitting by a molecular clock
## of mitochondrial DNA. Journal of Molecular Evolution, 22, 160-174.
##
##########################################################################/**
#
# @RdocClass HKY
#
# @title "The HKY class"
#
# \description{
# This class implements the HKY GTR-submodel.
#
# The rate parameters are the following: "Alpha", "Beta".
# @classhierarchy
# }
# \references{
# Hasegawa, M Kishino, H and Yano, T (1985) Dating of human-ape splitting by a molecular clock
# of mitochondrial DNA Journal of Molecular Evolution 22:160-174 \url{http://bit.ly/a9AxKm}
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{rate.params}{Rate parameters.}
# \item{base.freqs}{Base frequency parameters.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution process object
# p<-HKY(rate.params=list( "Alpha"=10,"Beta"=2),
# base.freqs=c(4,3,2,1)/10
# )
# # get a summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-NucleotideSequence(length=20,processes=list(list(p)))
# # sample states
# sampleStates(s)
# # make the first five positions invariable
# setRateMultipliers(s,p,0,1:5)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GTR UNREST GeneralSubstitution TN93
# }
#
#*/###########################################################################
setConstructorS3(
"HKY",
function(
name="Anonymous",
rate.params=list(
"Alpha" =1,
"Beta" =1
),
base.freqs=c(0.25,0.25,0.25,0.25),
...
) {
this<-GTR();
this<-extend(
this,
"HKY",
.hky.params=list(
"Alpha" =NA,
"Beta" =NA
)
);
this$name<-name;
this$baseFreqs<-base.freqs;
this$rateParamList<-rate.params;
return(this);
},
enforceRCC=TRUE
);
##
## Method: getRateParamList
##
###########################################################################/**
#
# @RdocMethod getRateParamList
#
# @title "Get the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An HKY object.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters.
# }
#
# \examples{
# # create HKY object
# p<-HKY()
# # set/get rate parameters
# setRateParamList(p,list(
# "Alpha"=1,
# "Beta"=0.5
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "Alpha"=1,
# "Beta"=3
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParamList",
class="HKY",
function(
this,
...
){
this$.hky.params;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParamList
##
###########################################################################/**
#
# @RdocMethod setRateParamList
#
# @title "Set the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An HKY object.}
# \item{value}{A list containing the rate parameters.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters (invisible).
# }
#
# \examples{
# # create HKY object
# p<-HKY()
# # set/get rate parameters
# setRateParamList(p,list(
# "Alpha"=1,
# "Beta"=0.5
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "Alpha"=1,
# "Beta"=3
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParamList",
class="HKY",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(missing(value)){
throw("No new value provided!\n");
}
else if(!is.list(value)){
throw("The provided value must be a list!\n");
}
else if(any((as.numeric(value)) < 0)){
throw("Cannot set negative rate parameter!\n");
}
else {
# Get the rate parameter names:
names<-names(this$.hky.params);
value.names<-names(value);
if(.checkRateParamList(this,names,value.names)) {
this$.hky.params<-value;
# Setting the GTR rate parameters:
gtr.params<-list(
"a"=value[["Alpha"]],
"b"=value[["Beta"]],
"c"=value[["Beta"]],
"d"=value[["Beta"]],
"e"=value[["Beta"]],
"f"=value[["Alpha"]]
);
setRateParamList.GTR(this, value=gtr.params);
}
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateParam
##
###########################################################################/**
#
# @RdocMethod getRateParam
#
# @title "Get the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An HKY object.}
# \item{name}{The name of the rate parameter.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters.
# }
#
# \examples{
# # construct HKY object
# p<-HKY();
# # set/get a rate parameter
# setRateParam(p,"Alpha",4)
# getRateParam(p,"Beta")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParam",
class="HKY",
function(
this,
name,
...
){
if(missing(name)){
throw("No rate parameter name specified!\n");
}
else {
.getRateParam(this,name,this$.hky.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParam
##
###########################################################################/**
#
# @RdocMethod setRateParam
#
# @title "Set the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An HKY object.}
# \item{name}{The name of the rate parameter.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of the rate parameter (invisible).
# }
#
# \examples{
# # construct HKY object
# p<-HKY();
# # set/get a rate parameter
# setRateParam(p,"Alpha",4)
# getRateParam(p,"Beta")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParam",
class="HKY",
function(
this,
name,
value,
...
){
.checkWriteProtection(this);
if(missing(name)){
throw("No rate parameter name specified!\n");
} else {
.setRateParam(this,name,value,this$.hky.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getBaseFreqs
##
###########################################################################/**
#
# @RdocMethod getBaseFreqs
#
# @title "Get the base frequency parameters"
#
# \description{
# @get "title".
#
# The order of the frequency parameters must match with the order of symbols
# in the NucleotideAlphabet objects.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An HKY object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix containing the base frequency parameters.
# }
#
# \examples{
# # construct object
# p<-HKY()
# # set/get base frequency parameters
# setBaseFreqs(p,c(2,1,2,1)/6)
# getBaseFreqs(p)
# # set/get base frequency parameters via virtual field
# p$baseFreqs<-c(4,4,1,1)/10
# p$baseFreqs
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getBaseFreqs",
class="HKY",
function(
this,
...
){
getBaseFreqs.GTR(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setBaseFreqs
##
###########################################################################/**
#
# @RdocMethod setBaseFreqs
#
# @title "Set the base frequency parameters"
#
# \description{
# @get "title".
#
# The order of the frequency parameters must match with the order of symbols
# in the NucleotideAlphabet objects.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An HKY object.}
# \item{value}{A vector of base frequencies.}
# \item{...}{Not used.}
# }
#
# \value{
# value (invisible)
# }
#
# \examples{
# # construct object
# p<-HKY()
# # set/get base frequency parameters
# setBaseFreqs(p,c(2,1,2,1)/6)
# getBaseFreqs(p)
# # set/get base frequency parameters via virtual field
# p$baseFreqs<-c(4,4,1,1)/10
# p$baseFreqs
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setBaseFreqs",
class="HKY",
function(
this,
value,
...
){
setBaseFreqs.GTR(this,value);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency.HKY
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="HKY",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# Rate parameters should not be negative:
if(any(this$.hky.params < 0 )){
throw("Found negative HKY rate parameters!\n");
}
else {
if(
this$.gtr.params[["a"]]!=this$.hky.params[["Alpha"]]|
this$.gtr.params[["b"]]!=this$.hky.params[["Beta"]]|
this$.gtr.params[["c"]]!=this$.hky.params[["Beta"]]|
this$.gtr.params[["d"]]!=this$.hky.params[["Beta"]]|
this$.gtr.params[["e"]]!=this$.hky.params[["Beta"]]|
this$.gtr.params[["f"]]!=this$.hky.params[["Alpha"]]
) {
throw("The HKY parameters are not consistent with the GTR parameters!\n");
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.HKY
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-NucleotideAlphabet()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="HKY",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
.addSummaryAlphabet(this);
if (class(this)[[1]] == "HKY") {
this$.summary$"Rate parameters"<-paste(names(this$.hky.params),this$.hky.params,sep=" = ",collapse=", ");
}
this$.summary$"Transition/transversion rate ratio"<-(this$.hky.params[["Alpha"]]/this$.hky.params[["Beta"]]);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
######### end of HKY methods ############
##
## Constructor: F81
##
## Felsenstein, J. (1981) Evolutionary trees from DNA sequences: a maximum likelihood approach.
## Journal of Molecular Evolution, 17, 368-376.
##
##########################################################################/**
#
# @RdocClass F81
#
# @title "The F81 class"
#
# \description{
# This class implements the F81 GTR-submodel.
#
# @classhierarchy
# }
# \references{
# Felsenstein, J (1981) Evolutionary trees from DNA sequences: a maximum likelihood approach -
# Journal of Molecular Evolution 17:368-376 \url{http://dx.doi.org/10.1007/BF01734359}
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{base.freqs}{Base frequency parameters.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution process object
# p<-F81(base.freqs=c(1,2,3,4)/10)
# # get a summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-NucleotideSequence(length=20,processes=list(list(p)))
# # sample states
# sampleStates(s)
# # make the first five positions invariable
# setRateMultipliers(s,p,0,1:5)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GTR UNREST GeneralSubstitution HKY
# }
#
#*/###########################################################################
setConstructorS3(
"F81",
function(
name="Anonymous",
base.freqs=c(0.25,0.25,0.25,0.25),
...
) {
this<-GTR(...);
this<-extend(
this,
"F81"
);
this$name<-name;
this$baseFreqs<-base.freqs;
return(this);
},
enforceRCC=TRUE
);
##
## Method: getRateParamList
##
###########################################################################/**
#
# @RdocMethod getRateParamList
#
# @title "Forbidden action: getting the list of rate parameters"
#
# \description{
# @get "title".
#
# This model has no rate parameters.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# The object.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParamList",
class="F81",
function(
this,
...
){
cat("The F81 model has no rate parameters!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParamList
##
###########################################################################/**
#
# @RdocMethod setRateParamList
#
# @title "Forbidden action: getting the list of rate parameters"
#
# \description{
# @get "title".
#
# This model has no rate parameters.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# The object.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParamList",
class="F81",
function(
this,
value,
...
){
cat("The F81 model has no rate parameters!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateParam
##
###########################################################################/**
#
# @RdocMethod getRateParam
#
# @title "Forbidden action: the value of a rate parameters"
#
# \description{
# @get "title".
#
# This model has no rate parameters.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{name}{The name of the rate parameter.}
# \item{...}{Not used.}
# }
#
# \value{
# The object.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParam",
class="F81",
function(
this,
name,
...
){
cat("The F81 model has no rate parameters!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParam
##
###########################################################################/**
#
# @RdocMethod setRateParam
#
# @title "Forbidden action: getting the list of rate parameters"
#
# \description{
# @get "title".
#
# This model has no rate parameters.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{name}{Not used.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# The object.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParam",
class="F81",
function(
this,
name,
value,
...
){
cat("The F81 model has no rate parameters!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getBaseFreqs
##
###########################################################################/**
#
# @RdocMethod getBaseFreqs
#
# @title "Get the base frequency parameters"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A F81 object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix containing the base frequency parameters.
# }
#
# \examples{
# # construct a F81 object
# p<-F81()
# # set/get base frequency parameters
# setBaseFreqs(p,c(2,1,2,1)/6)
# getBaseFreqs(p)
# # set/get base frequency parameters via virtual field
# p$baseFreqs<-c(4,4,1,1)/10
# p$baseFreqs
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getBaseFreqs",
class="F81",
function(
this,
...
){
getBaseFreqs.GTR(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setBaseFreqs
##
###########################################################################/**
#
# @RdocMethod setBaseFreqs
#
# @title "Set the base frequency parameters"
#
# \description{
# @get "title".
#
# The order of the frequency parameters must match with the order of symbols
# in the NucleotideAlphabet objects.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A F81 object.}
# \item{value}{A vector of base frequencies.}
# \item{...}{Not used.}
# }
#
# \value{
# value (invisible)
# }
#
# \examples{
# # construct a F81 object
# p<-F81()
# # set/get base frequency parameters
# setBaseFreqs(p,c(2,1,2,1)/6)
# getBaseFreqs(p)
# # set/get base frequency parameters via virtual field
# p$baseFreqs<-c(4,4,1,1)/10
# p$baseFreqs
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setBaseFreqs",
class="F81",
function(
this,
value,
...
){
setBaseFreqs.GTR(this,value);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency.F81
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="F81",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
if(any(as.numeric(this$.gtr.params) != 1)){
throw("GTR parameters are not consistent with the F81 model!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.F81
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-NucleotideAlphabet()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="F81",
function(
object,
...
){
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
######### end of F81 methods ############
##
## Constructor: K80
##
## Kimura, M. (1980) A simple method for estimating evolutionary rates of base substitutions
## through comparative studies of nucleotide sequences. Journal of Molecular Evolution, 16, 111-120.
##
##########################################################################/**
#
# @RdocClass K80
#
# @title "The K80 class"
#
# \description{
# This class implements the K80 (Kimura 2-parameter) GTR-submodel.
#
# The rate parameters are the following: "Alpha", "Beta".
# @classhierarchy
# }
# \references{
# Kimura, M. (1980) A simple method for estimating evolutionary rates of base substitutions
# through comparative studies of nucleotide sequences. Journal of Molecular Evolution 16:111-120
# \url{http://dx.doi.org/10.1007/BF01731581}
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{rate.params}{Rate parameters.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution process object
# p<-K80(rate.params=list( "Alpha"=6,"Beta"=2),
# base.freqs=c(4,3,2,1)/10
# )
# # get a summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-NucleotideSequence(length=20,processes=list(list(p)))
# # sample states
# sampleStates(s)
# # make the first five positions invariable
# setRateMultipliers(s,p,0,1:5)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GTR UNREST GeneralSubstitution TN93
# }
#
#*/###########################################################################
setConstructorS3(
"K80",
function(
name="Anonymous",
rate.params=list(
"Alpha" =1,
"Beta" =1
),
...
) {
this<-GTR();
this<-extend(
this,
"K80",
.k80.params=list(
"Alpha" =NA,
"Beta" =NA
)
);
this$name<-name;
this$rateParamList<-rate.params;
return(this);
},
enforceRCC=TRUE
);
##
## Method: getRateParamList
##
###########################################################################/**
#
# @RdocMethod getRateParamList
#
# @title "Get the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A K80 object.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters.
# }
#
# \examples{
# # create K80 object
# p<-K80()
# # set/get rate parameters
# setRateParamList(p,list(
# "Alpha"=1,
# "Beta"=0.5
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "Alpha"=1,
# "Beta"=3
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParamList",
class="K80",
function(
this,
...
){
this$.k80.params;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParamList
##
###########################################################################/**
#
# @RdocMethod setRateParamList
#
# @title "Set the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A K80 object.}
# \item{value}{A list containing the rate parameters.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters (invisible).
# }
#
# \examples{
# # create K80 object
# p<-K80()
# # set/get rate parameters
# setRateParamList(p,list(
# "Alpha"=1,
# "Beta"=0.5
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "Alpha"=1,
# "Beta"=3
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParamList",
class="K80",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(missing(value)){
throw("No new value provided!\n");
}
else if(!is.list(value)){
throw("The provided value must be a list!\n");
}
else if(any((as.numeric(value)) < 0)){
throw("Cannot set negative rate parameter!\n");
}
else {
# Get the rate parameter names:
names<-names(this$.k80.params);
value.names<-names(value);
if(.checkRateParamList(this,names,value.names)) {
this$.k80.params<-value;
# Setting the GTR rate parameters:
gtr.params<-list(
"a"=value[["Alpha"]],
"b"=value[["Beta"]],
"c"=value[["Beta"]],
"d"=value[["Beta"]],
"e"=value[["Beta"]],
"f"=value[["Alpha"]]
);
setRateParamList.GTR(this, value=gtr.params);
}
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateParam
##
###########################################################################/**
#
# @RdocMethod getRateParam
#
# @title "Get the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A K80 object.}
# \item{name}{The name of the rate parameter.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # construct a K80 object
# p<-K80();
# # set/get a rate parameter
# setRateParam(p,"Alpha",4)
# getRateParam(p,"Beta")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParam",
class="K80",
function(
this,
name,
...
){
if(missing(name)){
throw("No rate parameter name specified!\n");
}
else {
.getRateParam(this,name,this$.k80.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParam
##
###########################################################################/**
#
# @RdocMethod setRateParam
#
# @title "Set the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A K80 object.}
# \item{name}{The name of the rate parameter.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of the rate parameter (invisible).
# }
#
# \examples{
# # construct a K80 object
# p<-K80();
# # set/get a rate parameter
# setRateParam(p,"Alpha",4)
# getRateParam(p,"Beta")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParam",
class="K80",
function(
this,
name,
value,
...
){
.checkWriteProtection(this);
if(missing(name)){
throw("No rate parameter name specified!\n");
} else {
.setRateParam(this,name,value,this$.k80.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getBaseFreqs
##
###########################################################################/**
#
# @RdocMethod getBaseFreqs
#
# @title "Get the base frequency parameters"
#
# \description{
# @get "title".
#
# The order of the frequency parameters must match with the order of symbols
# in the NucleotideAlphabet objects. The K80 model has equal base frequencies.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A K80 object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix containing the base frequency parameters.
# }
#
# \examples{
# # construct object
# p<-K80()
# # get base frequency parameters
# getBaseFreqs(p) # uniform
# # set/get base frequency parameters via virtual field
# p$baseFreqs # uniform
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getBaseFreqs",
class="K80",
function(
this,
...
){
getBaseFreqs.GTR(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setBaseFreqs
##
###########################################################################/**
#
# @RdocMethod setBaseFreqs
#
# @title "Forbidden action: setting the base frequency parameters for a K80 object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setBaseFreqs",
class="K80",
function(
this,
value,
...
){
# Do not allow to modify the default base frequency distribution, which is uniform.
throw("You are not allowed to set the base frequencies for the K80 model!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency.K80
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="K80",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# Rate parameters should not be negative:
if(any(this$.k80.params < 0 )){
throw("Found negative K80 rate parameters!\n");
}
else {
if(
this$.gtr.params[["a"]]!=this$.k80.params[["Alpha"]]|
this$.gtr.params[["b"]]!=this$.k80.params[["Beta"]]|
this$.gtr.params[["c"]]!=this$.k80.params[["Beta"]]|
this$.gtr.params[["d"]]!=this$.k80.params[["Beta"]]|
this$.gtr.params[["e"]]!=this$.k80.params[["Beta"]]|
this$.gtr.params[["f"]]!=this$.k80.params[["Alpha"]]
) {
throw("The K80 parameters are not consistent with the GTR parameters!\n");
}
else if ( !all.equal(as.numeric(this$.equ.dist), as.numeric(rep(0.25,times=4)) ) ){
throw("The equlibrium distribution of the K80 model should be uniform!\n");
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.K80
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-NucleotideAlphabet()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="K80",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
.addSummaryAlphabet(this);
if (class(this)[[1]] == "K80") {
this$.summary$"Rate parameters"<-paste(names(this$.k80.params),this$.k80.params,sep=" = ",collapse=", ");
}
this$.summary$"Transition/transversion rate ratio"<-(this$.k80.params[["Alpha"]]/this$.k80.params[["Beta"]]);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
######### end of K80 methods ############
##
## Constructor: K81
##
## M. Kimura, Estimation of evolutionary sequences between homologous nucleotide sequences,
## Proc. Natl. Acad. Sci. USA 78 (1981), pp. 454-458.
##
##########################################################################/**
#
# @RdocClass K81
#
# @title "The K81 class"
#
# \description{
# This class implements the K81 (Kimura 3-parameter) GTR-submodel.
#
# The rate parameters are the following: "Alpha", "Beta","Gamma".
# @classhierarchy
# }
# \references{
# Kimura, M (1981) Estimation of evolutionary sequences between homologous nucleotide sequences -
# Proc. Natl. Acad. Sci. USA 78:454-458 \url{http://dx.doi.org/10.1073/pnas.78.1.454}
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{rate.params}{Rate parameters.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution process object
# p<-K81(rate.params=list( "Alpha"=10,"Beta"=2,"Gamma"=5))
# # get a summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-NucleotideSequence(length=20,processes=list(list(p)))
# # sample states
# sampleStates(s)
# # make the first five positions invariable
# setRateMultipliers(s,p,0,1:5)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GTR UNREST GeneralSubstitution HKY
# }
#
#*/###########################################################################
setConstructorS3(
"K81",
function(
name="Anonymous",
rate.params=list(
"Alpha" =1,
"Beta" =1,
"Gamma" =1
),
...
) {
this<-GTR();
this<-extend(
this,
"K81",
.k81.params=list(
"Alpha" =NA,
"Beta" =NA,
"Gamma" =NA
)
);
this$name<-name;
this$rateParamList<-rate.params;
return(this);
},
enforceRCC=TRUE
);
##
## Method: getRateParamList
##
###########################################################################/**
#
# @RdocMethod getRateParamList
#
# @title "Get the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta, Gamma.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A K81 object.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters.
# }
#
# \examples{
# # create K81 object
# p<-K81()
# # set/get rate parameters
# setRateParamList(p,list(
# "Alpha"=1,
# "Beta"=0.5,
# "Gamma"=2
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "Alpha"=1,
# "Beta"=3,
# "Gamma"=2
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParamList",
class="K81",
function(
this,
...
){
this$.k81.params;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParamList
##
###########################################################################/**
#
# @RdocMethod setRateParamList
#
# @title "Set the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta, Gamma.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A K81 object.}
# \item{value}{A list containing the rate parameters.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters (invisible).
# }
#
# \examples{
# # create K81 object
# p<-K81()
# # set/get rate parameters
# setRateParamList(p,list(
# "Alpha"=1,
# "Beta"=0.5,
# "Gamma"=2
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "Alpha"=1,
# "Beta"=3,
# "Gamma"=2
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParamList",
class="K81",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(missing(value)){
throw("No new value provided!\n");
}
else if(!is.list(value)){
throw("The provided value must be a list!\n");
}
else if(any((as.numeric(value)) < 0)){
throw("Cannot set negative rate parameter!\n");
}
else {
# Get the rate parameter names:
names<-names(this$.k81.params);
value.names<-names(value);
if(.checkRateParamList(this,names,value.names)) {
this$.k81.params<-value;
# Setting the GTR rate parameters:
gtr.params<-list(
"a"=value[["Alpha"]],
"b"=value[["Beta"]],
"c"=value[["Gamma"]],
"d"=value[["Gamma"]],
"e"=value[["Beta"]],
"f"=value[["Alpha"]]
);
setRateParamList.GTR(this, value=gtr.params);
}
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateParam
##
###########################################################################/**
#
# @RdocMethod getRateParam
#
# @title "Get the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta, Gamma.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A K81 object.}
# \item{name}{The name of the rate parameter.}
# \item{...}{Not used.}
# }
#
# \value{
# The value of the rate parameter.
# }
#
# \examples{
# # construct a K81 object
# p<-K81();
# # set/get a rate parameter
# setRateParam(p,"Alpha",4)
# getRateParam(p,"Gamma")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParam",
class="K81",
function(
this,
name,
...
){
if(missing(name)){
throw("No rate parameter name specified!\n");
}
else {
.getRateParam(this,name,this$.k81.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParam
##
###########################################################################/**
#
# @RdocMethod setRateParam
#
# @title "Set the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta, Gamma.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A K81 object.}
# \item{name}{The name of the rate parameter.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of the rate parameter (invisible).
# }
#
# \examples{
# # construct a K80 object
# p<-K81();
# # set/get a rate parameter
# setRateParam(p,"Alpha",4)
# getRateParam(p,"Gamma")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParam",
class="K81",
function(
this,
name,
value,
...
){
.checkWriteProtection(this);
if(missing(name)){
throw("No rate parameter name specified!\n");
} else {
.setRateParam(this,name,value,this$.k81.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getBaseFreqs
##
###########################################################################/**
#
# @RdocMethod getBaseFreqs
#
# @title "Get the base frequency parameters"
#
# \description{
# @get "title".
#
# The order of the frequency parameters must match with the order of symbols
# in the NucleotideAlphabet objects. The K81 model has equal base frequencies.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A K81 object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix containing the base frequency parameters.
# }
#
# \examples{
# # construct object
# p<-K81()
# # get base frequency parameters
# getBaseFreqs(p) # uniform
# # set/get base frequency parameters via virtual field
# p$baseFreqs # uniform
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getBaseFreqs",
class="K81",
function(
this,
...
){
getBaseFreqs.GTR(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setBaseFreqs
##
###########################################################################/**
#
# @RdocMethod setBaseFreqs
#
# @title "Forbidden action: setting the base frequency parameters for a K81 model"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setBaseFreqs",
class="K81",
function(
this,
value,
...
){
throw("You are not allowed to set the base frequencies for the K81 model!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency.K81
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="K81",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# Rate parameters should not be negative:
if(any(this$.k81.params < 0 )){
throw("Found negative K81 rate parameters!\n");
}
else {
if(
this$.gtr.params[["a"]]!=this$.k81.params[["Alpha"]]|
this$.gtr.params[["b"]]!=this$.k81.params[["Beta"]]|
this$.gtr.params[["c"]]!=this$.k81.params[["Gamma"]]|
this$.gtr.params[["d"]]!=this$.k81.params[["Gamma"]]|
this$.gtr.params[["e"]]!=this$.k81.params[["Beta"]]|
this$.gtr.params[["f"]]!=this$.k81.params[["Alpha"]]
) {
throw("The K81 parameters are not consistent with the GTR parameters!\n");
}
else if ( !all.equal(as.numeric(this$.equ.dist), as.numeric(rep(0.25,times=4)) ) ){
throw("The equlibrium distribution of the K81 model should be uniform!\n");
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.K81
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-NucleotideAlphabet()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="K81",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
.addSummaryAlphabet(this);
if (class(this)[[1]] == "K81") {
this$.summary$"Rate parameters"<-paste(names(this$.k81.params),this$.k81.params,sep=" = ",collapse=", ");
}
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
######### end of K81 methods ############
##
## Constructor: T92
##
## Tamura, K. 1992. Estimation of the number of nucleotide substitutions when
## there are strong transition-transversion and G+C content biases. Molecular Biology and Evolution 9:678-687.
##
##########################################################################/**
#
# @RdocClass T92
#
# @title "The T92 class"
#
# \description{
# This class implements the T92 GTR-submodel.
#
# The rate parameters are the following: "Alpha", "Beta","Gamma".
# The \code{theta} virtual field stores the GC content parameter.
#
# @classhierarchy
# }
# \references{
# Tamura, K. (1992) Estimation of the number of nucleotide substitutions when
# there are strong transition-transversion and G+C content biases - Molecular Biology and
# Evolution 9:678-687 \url{http://bit.ly/c6Pe0q}
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{rate.params}{Rate parameters.}
# \item{theta}{GC content (0.5 by default).}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution process object
# p<-T92(rate.params=list( "Alpha"=10,"Beta"=2),theta=0.8)
# # get a summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-NucleotideSequence(length=20,processes=list(list(p)))
# # sample states
# sampleStates(s)
# # make the first five positions invariable
# setRateMultipliers(s,p,0,1:5)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GTR UNREST GeneralSubstitution HKY
# }
#
#*/###########################################################################
setConstructorS3(
"T92",
function(
name="Anonymous",
rate.params=list(
"Alpha" =1,
"Beta" =1
),
theta=0.5, # GC content
...
) {
this<-GTR();
this<-extend(
this,
"T92",
.theta=NA,
.t92.params=list(
"Alpha" =NA,
"Beta" =NA
)
);
this$name<-name;
this$theta<-theta;
this$rateParamList<-rate.params;
return(this);
},
enforceRCC=TRUE
);
##
## Method: getRateParamList
##
###########################################################################/**
#
# @RdocMethod getRateParamList
#
# @title "Get the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A T92 object.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters.
# }
#
# \examples{
# # create a T92 object
# p<-T92()
# # set/get rate parameters
# setRateParamList(p,list(
# "Alpha"=1,
# "Beta"=0.5
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "Alpha"=1,
# "Beta"=3
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParamList",
class="T92",
function(
this,
...
){
this$.t92.params;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParamList
##
###########################################################################/**
#
# @RdocMethod setRateParamList
#
# @title "Set the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A T92 object.}
# \item{value}{A list containing the rate parameters.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters (invisible).
# }
#
# \examples{
# # create a T92 object
# p<-T92()
# # set/get rate parameters
# setRateParamList(p,list(
# "Alpha"=1,
# "Beta"=0.5
# ))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list(
# "Alpha"=1,
# "Beta"=3
# )
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParamList",
class="T92",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(missing(value)){
throw("No new value provided!\n");
}
else if(!is.list(value)){
throw("The provided value must be a list!\n");
}
else if(any((as.numeric(value)) < 0)){
throw("Cannot set negative rate parameter!\n");
}
else {
# Get the rate parameter names:
names<-names(this$.t92.params);
value.names<-names(value);
if(.checkRateParamList(this,names,value.names)) {
# Set the rate parameters:
# The parmeters are named as in
# "Ziheng Yang: Computational Molecular Evolution, Oxford university Press, Oxford, 2006", pp. 34.
this$.t92.params<-value;
# Setting the GTR rate parameters:
gtr.params<-list(
"a"=value[["Alpha"]],
"b"=value[["Beta"]],
"c"=value[["Beta"]],
"d"=value[["Beta"]],
"e"=value[["Beta"]],
"f"=value[["Alpha"]]
);
setRateParamList.GTR(this, value=gtr.params);
}
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateParam
##
###########################################################################/**
#
# @RdocMethod getRateParam
#
# @title "Get the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A T92 object.}
# \item{name}{The name of the rate parameter.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # construct a T92 object
# p<-T92();
# # set/get a rate parameter
# setRateParam(p,"Alpha",4)
# getRateParam(p,"Beta")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParam",
class="T92",
function(
this,
name,
...
){
if(missing(name)){
throw("No rate parameter name specified!\n");
}
else {
.getRateParam(this,name,this$.t92.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParam
##
###########################################################################/**
#
# @RdocMethod setRateParam
#
# @title "Set the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Alpha, Beta.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A T92 object.}
# \item{name}{The name of the rate parameter.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of the rate parameter (invisible).
# }
#
# \examples{
# # construct a T92 object
# p<-T92();
# # set/get a rate parameter
# setRateParam(p,"Alpha",4)
# getRateParam(p,"Beta")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParam",
class="T92",
function(
this,
name,
value,
...
){
.checkWriteProtection(this);
if(missing(name)){
throw("No rate parameter name specified!\n");
} else {
.setRateParam(this,name,value,this$.t92.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getTheta
##
###########################################################################/**
#
# @RdocMethod getTheta
#
# @title "Get the GC content"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A T92 object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # construct a T92 object
# p<-T92()
# # set/get GC content
# setTheta(p,0.6)
# getTheta(p)
# # set/get GC content via virtual field
# p$theta<-0.3
# p$theta
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getTheta",
class="T92",
function(
this,
...
){
this$.theta;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setTheta
##
###########################################################################/**
#
# @RdocMethod setTheta
#
# @title "Set the GC content"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A T92 object.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of theta (invisible).
# }
#
# \examples{
# # construct a T92 object
# p<-T92()
# # set/get GC content
# setTheta(p,0.6)
# getTheta(p)
# # set/get GC content via virtual field
# p$theta<-0.3
# p$theta
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setTheta",
class="T92",
function(
this,
value,
...
){
if(missing(value)){
throw("No new value provided!\n");
}
else if(!is.numeric(value)){
throw("Theta must be numeric!\n");
}
else if (length(value) != 1){
throw("The value of theta must be a vector of length 1!\n");
}
else if(value > 1){
throw("Theta (GC content) cannot be larger than 1!\n");
}
else {
this$.theta<-value;
# WARNING - here we rely on the T C G A symbol order in the nucleotide alphabet.
base.freqs<-c(
((1-this$.theta)/2), # T
(this$.theta/2), # C
((1-this$.theta)/2), # A
((this$.theta)/2) # G
);
}
# Set the GTR base frequencies:
setBaseFreqs.GTR(this,base.freqs);
return(invisible(value));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency.T92
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="T92",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# Rate parameters should not be negative:
if(any(this$.t92.params < 0 ) | (this$.theta < 0)){
throw("Found negative T92 rate parameters!\n");
}
else {
if(
this$.gtr.params[["a"]]!=this$.t92.params[["Alpha"]]|
this$.gtr.params[["b"]]!=this$.t92.params[["Beta"]]|
this$.gtr.params[["c"]]!=this$.t92.params[["Beta"]]|
this$.gtr.params[["d"]]!=this$.t92.params[["Beta"]]|
this$.gtr.params[["e"]]!=this$.t92.params[["Beta"]]|
this$.gtr.params[["f"]]!=this$.t92.params[["Alpha"]]
) {
throw("The HKY parameters are not consistent with the GTR parameters!\n");
}
# Checking if the equlibrium distribution is consistent with theta:
base.freqs<-c(
((1-this$.theta)/2), # T
(this$.theta/2), # C
((1-this$.theta)/2), # A
((this$.theta)/2) # G
);
if(any(!PSRoot$my.all.equal(base.freqs, this$equDist))){
throw("Equlibrium distribution is not consistent with the theta value!\n");
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.T92
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-T92(theta=0.8)
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="T92",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
.addSummaryAlphabet(this);
if (class(this)[[1]] == "T92") {
this$.summary$"Rate parameters"<-paste(names(this$.t92.params),this$.t92.params,sep=" = ",collapse=", ");
this$.summary$"Theta (GC content)"<-this$.theta;
this$.summary$"Transition/transversion rate ratio"<-(this$.t92.params[["Alpha"]]/this$.t92.params[["Beta"]]);
}
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
######### end of T92 methods ############
##
## Constructor: F84
##
## Hasegawa, M., H. Kishino, and T. Yano. (1985) Dating of human-ape splitting by a molecular clock
## of mitochondrial DNA. Journal of Molecular Evolution, 22, 160-174.
##
##########################################################################/**
#
# @RdocClass F84
#
# @title "The F84 class"
#
# \description{
# This class implements the F84 GTR-submodel.
#
# The rate parameters are the following: Kappa.
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Object name.}
# \item{rate.params}{Rate parameters.}
# \item{base.freqs}{Base frequency parameters.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create substitution process object
# p<-F84(rate.params=list( "Kappa"=2), base.freqs=c(1,2,3,4))
# # get a summary
# summary(p)
# # display a bubble plot
# plot(p)
#
# # The following code demonstrates how to use
# # the process in a simulation.
#
# # create a sequence, attach process p
# s<-NucleotideSequence(length=20,processes=list(list(p)))
# # sample states
# sampleStates(s)
# # make the first five positions invariable
# setRateMultipliers(s,p,0,1:5)
# # get rate multipliers
# getRateMultipliers(s,p)
# # create a simulation object
# sim<-PhyloSim(root.seq=s,phylo=rcoal(2))
# # run simulation
# Simulate(sim)
# # print alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# GTR UNREST GeneralSubstitution HKY
# }
#
#*/###########################################################################
setConstructorS3(
"F84",
function(
name="Anonymous",
rate.params=list(
"Kappa" = 0
),
base.freqs=c(0.25,0.25,0.25,0.25)
) {
this<-GTR();
this<-extend(
this,
"F84",
.f84.params=list(
"Kappa" =NA
)
);
this$name<-name;
this$baseFreqs<-base.freqs;
this$rateParamList<-rate.params;
return(this);
},
enforceRCC=TRUE
);
##
## Method: getRateParamList
##
###########################################################################/**
#
# @RdocMethod getRateParamList
#
# @title "Get the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Kappa.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A F84 object.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters.
# }
#
# \examples{
# # create F84 object
# p<-F84()
# # set/get rate parameters
# setRateParamList(p,list("Kappa"=3))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list("Kappa"=2.5)
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParamList",
class="F84",
function(
this,
...
){
this$.f84.params;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParamList
##
###########################################################################/**
#
# @RdocMethod setRateParamList
#
# @title "Set the rate parameters"
#
# \description{
# @get "title".
#
# The rate parameters are: Kappa.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A F84 object.}
# \item{value}{A list containing the rate parameters.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of rate parameters (invisible).
# }
#
# \examples{
# # create F84 object
# p<-F84()
# # set/get rate parameters
# setRateParamList(p,list("Kappa"=3))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list("Kappa"=2.5)
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParamList",
class="F84",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(missing(value)){
throw("No new value provided!\n");
}
else if(!is.list(value)){
throw("The provided value must be a list!\n");
}
else if(any((as.numeric(value)) < 0)){
throw("Cannot set negative rate parameter!\n");
}
else {
# Get the rate parameter names:
names<-names(this$.f84.params);
value.names<-names(value);
if(.checkRateParamList(this,names,value.names)) {
this$.f84.params<-value;
# Setting the GTR rate parameters:
kappa<-value[["Kappa"]];
y<-(this$.equ.dist[1,"T"] + this$.equ.dist[1,"C"] );
r<-(this$.equ.dist[1,"A"] + this$.equ.dist[1,"G"] );
gtr.params<-list(
"a"=(1 + (kappa/y) ),
"b"=1,
"c"=1,
"d"=1,
"e"=1,
"f"=(1 + (kappa/r) )
);
setRateParamList.GTR(this, value=gtr.params);
}
}
return(invisible(value));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateParam
##
###########################################################################/**
#
# @RdocMethod getRateParam
#
# @title "Get the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Kappa.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A F84 object.}
# \item{name}{The name of the rate parameter.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create F84 object
# p<-F84()
# # set/get rate parameters
# setRateParamList(p,list("Kappa"=3))
# getRateParamList(p)
# # set/get rate parameters via virtual field
# p$rateParamList<-list("Kappa"=2.5)
# p$rateParamList
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateParam",
class="F84",
function(
this,
name,
...
){
if(missing(name)){
throw("No rate parameter name specified!\n");
}
else {
.getRateParam.GTR(this,name,this$.f84.params);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateParam
##
###########################################################################/**
#
# @RdocMethod setRateParam
#
# @title "Set the value of a rate parameter"
#
# \description{
# @get "title".
#
# The rate parameters are: Kappa.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A F84 object.}
# \item{name}{The name of the rate parameter.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of the rate parameter (invisible).
# }
#
# \examples{
# # construct a F84 object
# p<-F84();
# # set/get a rate parameter
# setRateParam(p,"Kappa",4)
# getRateParam(p,"Kappa")
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateParam",
class="F84",
function(
this,
name,
value,
...
){
.checkWriteProtection(this);
if(missing(name)){
throw("No rate parameter name specified!\n");
} else {
.setRateParam.GTR(this,name,value,this$.f84.params);
}
return(invisible(value));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getKappa
##
###########################################################################/**
#
# @RdocMethod getKappa
#
# @title "Get the transition transversion rate ratio"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A F84 object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # construct a F84 object
# p<-F84();
# # set/get Kappa
# setKappa(p,2)
# getKappa(p)
# # set/get Kappa via virtual field
# p$kappa<-4
# p$kappa
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getKappa",
class="F84",
function(
this,
...
){
getRateParam.F84(this, "Kappa");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setKappa
##
###########################################################################/**
#
# @RdocMethod setKappa
#
# @title "Get the transition transversion rate ratio"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A F84 object.}
# \item{value}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of Kappa (invisible).
# }
#
# \examples{
# # construct a F84 object
# p<-F84();
# # set/get Kappa
# setKappa(p,2)
# getKappa(p)
# # set/get Kappa via virtual field
# p$kappa<-4
# p$kappa
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setKappa",
class="F84",
function(
this,
value,
...
){
setRateParam.F84(this,"Kappa",value);
return(invisible(value));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getBaseFreqs
##
###########################################################################/**
#
# @RdocMethod getBaseFreqs
#
# @title "Get the base frequency parameters"
#
# \description{
# @get "title".
#
# The order of the frequency parameters must match with the order of symbols
# in the NucleotideAlphabet objects.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A F84 object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix containing the base frequency parameters.
# }
#
# \examples{
# # construct object
# p<-F84()
# # set/get base frequency parameters
# setBaseFreqs(p,c(2,1,2,1)/6)
# getBaseFreqs(p)
# # set/get base frequency parameters via virtual field
# p$baseFreqs<-c(4,4,1,1)/10
# p$baseFreqs
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getBaseFreqs",
class="F84",
function(
this,
...
){
getBaseFreqs.GTR(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setBaseFreqs
##
###########################################################################/**
#
# @RdocMethod setBaseFreqs
#
# @title "Set the base frequency parameters"
#
# \description{
# @get "title".
#
# The order of the frequency parameters must match with the order of symbols
# in the NucleotideAlphabet objects.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A F84 object.}
# \item{value}{A vector of base frequencies.}
# \item{...}{Not used.}
# }
#
# \value{
# value (invisible)
# }
#
# \examples{
# # construct object
# p<-F84()
# # set/get base frequency parameters
# setBaseFreqs(p,c(2,1,2,1)/6)
# getBaseFreqs(p)
# # set/get base frequency parameters via virtual field
# p$baseFreqs<-c(4,4,1,1)/10
# p$baseFreqs
# # get object summary
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setBaseFreqs",
class="F84",
function(
this,
value,
...
){
setBaseFreqs.GTR(this,value);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency.F84
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="F84",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# Rate parameters should not be negative:
if( any(this$.f84.params < 0 ) ){
throw("Found negative F84 rate parameters!\n");
}
else {
kappa<-this$.f84.params[["Kappa"]];
y<-(this$.equ.dist[1,"T"] + this$.equ.dist[1,"C"] );
r<-(this$.equ.dist[1,"A"] + this$.equ.dist[1,"G"] );
gtr.params<-list(
"a"=(1 + (kappa/y) ),
"b"=1,
"c"=1,
"d"=1,
"e"=1,
"f"=(1 + (kappa/r) )
);
if(any(names(gtr.params) != names(this$.gtr.params)) | any(!PSRoot$my.all.equal(as.numeric(gtr.params), as.numeric(this$.gtr.params) ) )){
throw("The Kappa value is not consistent with the GTR rate parameters!\n");
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.F84
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-F84(rate.params=list("Kappa"=3))
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="F84",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
.addSummaryAlphabet(this);
if (class(this)[[1]] == "F84") {
this$.summary$"Rate parameters"<-paste(names(this$.f84.params),this$.f84.params,sep=" = ",collapse=", ");
}
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
######### end of F84 methods ############
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
## Constructor: PSRootSummary
##
##########################################################################/**
#
# @RdocClass PSRootSummary
#
# @title "The PSRootSummary class"
#
# \description{
# PSRootSummary objects are blessed lists containing summary entries created by
# \code{summary.*} methods.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{summary}{A list.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setConstructorS3(
"PSRootSummary",
function(summary=list(),...){
# Stepping out of the R.oo framework to provide
# the expected behaviour.
class(summary)<-c("PSRootSummary");
summary;
},
###
enforceRCC=FALSE
);
##
## Method: print.PSRootSummary
##
###########################################################################/**
#
# @RdocMethod print
#
# @title "Print out a PSRootSummary object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A PSRootSummary object.}
# \item{...}{Not used.}
# }
#
# \value{
# The summary object (invisible).
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"print",
class="PSRootSummary",
appendVarArgs=FALSE,
function(
x,
...
){
this<-x;
cat("\n");
for (i in names(this)){
cat(paste(i,": ",this[[i]],"\n",sep=""));
}
cat("\n");
invisible(this);
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: checkConsistency;
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# The consisntency check is not implemented for PSRootSummary objects,
# the method prints out a warning about that.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="PSRootSummary",
function(
this,
...
){
warning("Consistency check is not implemented in class ",class(this)[[1]],"!\n");
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##########################################################################/**
#
# @RdocClass PSRoot
#
# @title "The root class for all phylosim objects"
#
# \description{
# The root class for all phylosim objects containig some utility methods.
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# obj<-PSRoot();
# ll(obj);
# }
#
# @author
#
#
# \seealso{
# Object
# }
#
#*/###########################################################################
setConstructorS3(
"PSRoot",
function(...){
extend(Object(), "PSRoot",
.comments=character(0),
.summary=list()
);
},
###
enforceRCC=TRUE
);
##
## Method: virtualAssignmentForbidden
##
###########################################################################/**
#
# @RdocMethod virtualAssignmentForbidden
#
# @title "Throws an error message informing the user about forbidden action on virtual a field"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PSRoot object.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"virtualAssignmentForbidden",
class="PSRoot",
###
function(
this,
...
){
throw("You cannot set the value of this virtual field directly!");
},
###
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: enableVirtual
##
###########################################################################/**
#
# @RdocMethod enableVirtual
#
# @title "Enable the use of virtual fields for a given object"
#
# \description{
# @get "title".
# R.oo disables the virtual field feature inside get/set methods. This method can be used to re-enable virtual fields.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PSRoot object.}
# \item{...}{Not used.}
# }
#
# \value{
# The PSRoot object.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"enableVirtual",
class="PSRoot",
###
function(
this,
...
){
attr(this,"disableGetMethods")<-NULL;
attr(this,"disableSetMethods")<-NULL;
this;
},
###
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: stringLength
##
###########################################################################/**
#
# @RdocDefault stringLength
#
#
# @title "Returns the string length of the character representation of an object"
#
# \description{
# @get "title".
# More useful as a static method.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# An integer vector of length one.
# }
#
# \examples{
# x<-"character representaion"
# # get the strign length of x
# stringLength(x)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"stringLength",
class="default",
function(
this,
...
){
this<-as.character(this);
if (length(this) != 1){throw("This function can handle only vectors of length 1!")};
return(length(strsplit(this,split="",fixed=TRUE)[[1]]));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: stringLengthVector
##
###########################################################################/**
#
# @RdocDefault stringLengthVector
#
#
# @title "Returns the string lengths of the character represenations of a collection of objects"
#
# \description{
# @get "title".
# More useful as a static method.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An array or a list of object.}
# \item{...}{Not used.}
# }
#
# \value{
# An integer vector with the corresponding lengths.
# }
#
# \examples{
# x<-c("character representaion","other string");
# # get the strign length of x
# stringLengthVector(x)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"stringLengthVector",
class="default",
function(
this,
...
){
as.numeric(apply(as.array(this),1,stringLength));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getMethodsList
###########################################################################/**
#
# @RdocMethod getMethodsList
#
# @title "Get the list of applicable methods for an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PSRoot object.}
# \item{...}{Not used.}
# }
#
# \value{
# The list of applicable methods.
# }
#
# \examples{
# # create an object
# o<-PSRoot()
# # get the applicable methods
# getMethodsList(o)
# # get methods via virtual field
# o$methodsList
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
##
setMethodS3(
"getMethodsList",
class="PSRoot",
function(
this,
...
){
cls <- class(this)[[1]]
clazz <- Class$forName(cls);
mlist <- getMethods(clazz);
# If the class has no methods, do not
# consider the methods from the parent class.
if(names(mlist)[[1]] == cls){
as.character(names(mlist[[1]]));
}
else {
return(character(0));
}
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: setMethodsList
##
###########################################################################/**
#
# @RdocMethod setMethodsList
#
# @title "Forbidden action: setting the list of applicable methods for an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setMethodsList",
class="PSRoot",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: ll
##
###########################################################################/**
#
# @RdocMethod ll
#
# @title "Display detailed information about the virtual fields and methods defined for a given object"
#
# \description{
# @get "title".
# The method prints the class of the object, all the parent classes,
# and the virtual fields and methods defined in the immediate class.
#
# This method provides a "quick and minimal" documentation for PhyloSim classes.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PSRoot object.}
# \item{quiet}{Do not print out methods list.}
# \item{...}{Not used.}
# }
#
# \value{
# Text.
# }
#
# \examples{
# # create a Site object
# s<-Site()
# ll(s)
# # get information about the Process class
# ll(Process())
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"ll",
class="PSRoot",
function(
this,
quiet=FALSE,
...
){
class<-class(this);
parents<-class[-1];
class<-class[[1]]
methods<-getMethodsList(this);
fields<-getFields(this);
text<-character(0);
pretty.print<-function(vec,text){
tmp<-"";
if(length(vec) > 0 ){
tmp<-paste(tmp," ",vec,sep="",collapse="\n");
paste(text,tmp,"\n",sep="");
} else {
return(text);
}
}
text<-paste(text,"\nClass: ",class,"\n",sep="");
text<-paste(text,"Inherits from: ",paste(parents,collapse=" "),"\n",sep="");
text<-paste(text,"Fields (",length(fields),"):\n",sep="");
text<-pretty.print(fields,text);
# Discriminate between the methods implementing
# virtual fileds and the rest:
vfields<-character(0);
methods.not.virtual<-character(0);
num.args<-function(fun){
length(formals(fun))
}
method.to.field<-function(method){
method<-sub('^(get|set)(.*)','\\2',method);
tmp<-as.array(strsplit(method,"",fixed=TRUE))[[1]];
tmp[1]<-tolower(tmp[1]);
paste(tmp,collapse="");
}
classify.method<-function(method,limit) {
if( num.args( paste(method,".",class(this)[[1]],sep="") ) == limit){
vfields<<-c(vfields,method.to.field(method));
} else {
methods.not.virtual<<-c(methods.not.virtual,method);
}
}
for(method in methods){
# Get methods for virtual fields have 2 aguments: "this" and "...".
if(length(grep("^get",method,perl=TRUE)) == 1) {
classify.method (method,limit=2)
}
# Set methods for virtual fields have 3 aguments: "this", "..." and "value".
else if (length(grep("^set",method,perl=TRUE)) == 1) {
classify.method (method,limit=3)
} else {
methods.not.virtual<-c(methods.not.virtual,method);
}
}
vfields<-sort(unique(vfields));
lapply(methods.not.virtual,
function(name) {
tmp<-method.to.field(name);
if (length(intersect(tmp,vfields)) > 0 ) {
print(intersect(tmp,vfields));
throw("Method classification inconsistency! Blaming ",paste(intersect(tmp,vfields),collapse=" "),". \n");
}
}
);
text<-paste(text,"Virtual fields (",length(vfields),"):\n",sep="");
text<-pretty.print(vfields,text);
text<-paste(text,"Methods implemented in ",class," (",length(methods.not.virtual),"):\n",sep="");
text<-pretty.print(sort(methods.not.virtual),text);
text<-paste(text,"\n",sep="");
if(!quiet){ cat(text) }
invisible(text);
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: getComments
##
###########################################################################/**
#
# @RdocMethod getComments
#
# @title "Get the comments associated with an object"
#
# \description{
# @get "title".
#
# The comment field can contain any type of object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PSRoot object.}
# \item{...}{Not used.}
# }
#
# \value{
# The value of the comment field.
# }
#
# \examples{
# # create an object
# o<-PSRoot()
# # add some comments
# setComments(o,"Random comment")
# # get the comment
# getComments(o)
# # get/set the comment via virtual fiels
# o$comments<-"Second random comment"
# o$comments
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getComments",
class="PSRoot",
function(
this,
...
){
this$.comments;
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: setComments
##
###########################################################################/**
#
# @RdocMethod setComments
#
# @title "Set the comments associated with an object"
#
# \description{
# @get "title".
#
# The comment field can contain any type of object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PSRoot object.}
# \item{new_value}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# The new value of the comment field (invisible).
# }
#
# \examples{
# # create an object
# o<-PSRoot()
# # add some comments
# setComments(o,"Random comment")
# # get the comment
# getComments(o)
# # get/set the comment via virtual fiels
# o$comments<-"Second random comment"
# o$comments
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setComments",
class="PSRoot",
function(
this,
new_value,
...
){
this$.comments<-new_value;
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: PSRoot$my.all.equal
##
###########################################################################/**
#
# @RdocMethod my.all.equal
#
# @title "Test if two objects are nearly equal"
#
# \description{
# @get "title".
#
# This method simply calls \code{all.equal.default} with the tolerance parameter set to
# \code{.Machine$double.eps ^ 0.5}. More useful as a static method.
#
# }
#
# @synopsis
#
# \arguments{
# \item{static}{A PSRoot object.}
# \item{target}{R object.}
# \item{current}{Other R object, to be compared with target.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# PSRoot$my.all.equal(0.0,0.0001)
# PSRoot$my.all.equal(0.0,0.000000001)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"my.all.equal",
class="PSRoot",
function(
static,
target,
current,
...
){
static;
one<-target;
two<-current;
TOLERANCE<-.Machine$double.eps ^ 0.5;
if(missing(one) | missing (two)){
throw("Two objects are needed for comparison!\n");
}
else {
one<-as.double(one);
two<-as.double(two);
return(isTRUE(all.equal(one,two, tolerance=TOLERANCE)));
}
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: summary.PSRoot
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-PSRoot()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="PSRoot",
function(
object,
...
){
this<-object;
# Adding the Comments field:
if(length(this$.comments) > 0 ) {
this$.summary$Comments<-paste(this$.comments, collapse=", ");
}
obj<-PSRootSummary(summary=this$.summary);
this$.summary<-list();
# Return a summary object:
return(obj);
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: is.na.PSRoot
##
###########################################################################/**
#
# @RdocMethod is.na
#
# @title "Check if a PSRoot object is NA"
#
# \description{
# @get "title".
# PSRoot objects accanot be NA, so this method always returns FALSE.
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A PSRoot object.}
# \item{...}{Not used.}
# }
#
# \value{
# FALSE
# }
#
# \examples{
# is.na(PSRoot());
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"is.na",
class="PSRoot",
function(
x,
...
){
# We don't want our objects to be NA-s!
return(FALSE);
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: checkConsistency;
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# The consisntency check is not implemented in plain PSRoot objects,
# the method prints out a warning about that.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="PSRoot",
function(
this,
...
){
warning("Consistency check is not implemented in class ",class(this)[[1]],"!\n");
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: globalConsistencyCheck
##
###########################################################################/**
#
# @RdocMethod globalConsistencyCheck
#
# @title "Check the consistency of all objects inheriting form PSRoot in the current environment"
#
# \description{
# @get "title".
#
# This method searches for objects which inherit from PSRoot and calls \code{checkConsistency()} for all of them,
# which can take a lots of time. Prints the results of the checks as text.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns invisible TRUE if all checks are successful.
# }
#
# \examples{
# # create some objects
# a<-NucleotideAlphabet()
# s<-Site()
# p<-Process()
# # ask for a global consistency check
# PSRoot$globalConsistencyCheck();
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"globalConsistencyCheck",
class="PSRoot",
function(
...
){
for(name in ls(envir=.GlobalEnv)) {
obj<-get(name,envir=.GlobalEnv);
if (is.PSRoot(obj)) {
cat("Checking ",name," ... ");
if( checkConsistency((obj)) ) {
cat("OK\n");
}
}
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: plot.PSRoot
##
setMethodS3(
"plot",
class="PSRoot",
function(
...
){
cat("No plot method defined for this object!\n");
return(invisible(FALSE));
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: intersect.list.PSRoot
##
###########################################################################/**
#
# @RdocMethod intersect.list
#
# @title "Utility method returning the intersection of two lists"
#
# \description{
# @get "title".
# Duplicated elements are not considered.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PSRoot object.}
# \item{one}{A list of objects.}
# \item{two}{A list of objects.}
# \item{...}{Not used.}
# }
#
# \value{
# The list containing the intersection.
# }
#
# \examples{
# # create some lists
# a<-list(1,2,3);
# b<-c(a,list("a","b","c"))
# # get the intersection of a and b
# PSRoot$intersect.list(a,b)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"intersect.list",
class="PSRoot",
function(
this,
one,
two,
...
){
if(!is.list(one)){
throw("The first argument is not a list!\n");
}
if(!is.list(two)){
throw("The second argument is not a list!\n");
}
one<-unique(one);
two<-unique(two);
intersect<-list();
for (i in one){
for (j in two){
if(i == j) {
intersect<-c(intersect,list(i));
}
}
}
return(intersect);
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Method: is.PSRoot.default
##
###########################################################################/**
#
# @RdocDefault is.PSRoot
#
# @title "Check if an object inherits from PSRoot"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create some objects
# o<-PSRoot()
# a<-Alphabet()
# x<-Object()
# # check if they inherit form PSRoot
# is.PSRoot(o)
# is.PSRoot(a)
# is.PSRoot(x)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"is.PSRoot",
class="default",
function(
this,
...
){
if(!is.object(this)) {return(FALSE)}
inherits(this,"PSRoot");
},
private=FALSE,
protected=FALSE,
overwrite=TRUE,
conflict="warning"
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass PhyloSim
# \alias{phylosim}
#
# @title "The PhyloSim class"
#
# \description{
#
# PhyloSim is an extensible object-oriented framework for the Monte Carlo simulation
# of sequence evolution written in 100 percent \code{R}.
# It is built on the top of the \code{\link{R.oo}} and \code{\link{ape}} packages and uses
# Gillespie's direct method to simulate substitutions, insertions and deletions.
#
# Key features offered by the framework:
# \itemize{
# \item Simulation of the evolution of a set of discrete characters with arbitrary states evolving
# by a continuous-time Markov process with an arbitrary rate matrix.
# \item Explicit implementations of the most popular substitution models (for nucleotides, amino acids and codons).
# \item Simulation under the popular models of among-sites rate variation, like the gamma (+G) and invariants plus gamma (+I+G) models.
# \item The possibility to simulate with arbitrarily complex patterns of among-sites rate variation by setting the site specific rates according to any \code{R} expression.
# \item Simulation with one or more separate insertion and/or deletion processes acting on the sequences, which sample the insertion/deletion length from an arbitrary discrete distribution or an \code{R} expression (so all the probability distributions implemented in \code{R} are readily available for this purpose).
# \item Simulation of the effects of variable functional constraints over the sites by site-process-specific insertion and deletion tolerance parameters, which determine the rejection probability of a proposed insertion/deletion.
# \item The possibility of having a different set of processes and site-process-specific parameters for every site, which allow for an arbitrary number of partitions in the simulated data.
# \item Simulation of heterotachy and other cases of non-homogeneous evolution by allowing the user to set "node hook" functions altering the site properties at internal nodes of the phylogeny.
# \item The possibility to export the counts of various events ("branch statistics") as phylo objects (see \code{\link{exportStatTree.PhyloSim}}).
# }
#
# General notes:
# \itemize{
# \item The \code{Sequence} objects have no "immortal links". The simulation
# is aborted if the sequence length shrinks to zero. It is up to the user
# to choose sensible indel rates and sequence lengths to prevent that.
# \item The sites near the beginning and end of the sequences have less sites proposing
# insertion and deletion events around the so the insertion and deletion processes
# have an "edge effect". The user can simulate
# realistic flanking sequences to alleviate the edge effect in the simulation settings where
# it may be an issue.
# }
#
# Notes on performance:
# \itemize{
# \item The pure \code{R} implementation offers felxibility, but also comes
# with a slower simulation speed. If the \code{PSIM_FAST} object is present in the environment, a "fast & careless"
# mode is enabled. In this mode most of the error checking is skipped, increasing the speed.
# It is recomended that simulations are only run in fast mode if you are sure that the simulation
# settings are free from errors. It is probably a good practice to set up the simulations in normal mode
# with short sequences and enable fast mode when running the actual simulation with long sequences.
# \item Please note, that no "branch statistics" are saved in fast mode.
# \item Logging also has a negative impact on performance, so it's not a good idea to run
# large simulations with the logging enabled.
# \item The time needed to run a simulation depends not only on the number of the sites,
# but also on the length of the tree.
# \item Constructing \code{Sequence} objects with large number of sites is expensive. Avoid doing
# that inside a cycle.
# \item In the case of \code{Sequence} objects with a large number of sites (more than 10 000) the
# amount of available memory can be limiting as well.
# }
#
# The examples below demonstrate only some more common simulation settings,
# the framework offers much more flexibility. See the package
# vignette (\code{vignette("PhyloSim",package="phylosim")}) and the
# examples directory (\url{http://github.com/bsipos/phylosim/tree/master/examples/})
# for additional examples.
#
# @classhierarchy
# }
#
#
# \references{
# Gillespie, DT (1977) Exact stochastic simulation of coupled chemical reactions -
# J. Phys. Chem. 81 (25):2340-2361 \url{http://dx.doi.org/10.1021/j100540a008}
# }
#
# @synopsis
#
# \arguments{
# \item{phylo}{A rooted phylo object, constructed by the APE package.}
# \item{root.seq}{A valid Sequence object with Process objects attached. Used as the starting sequence during simulation.}
# \item{name}{The name of the object (a character vector of length one).}
# \item{log.file}{Name of the file used for logging.}
# \item{log.level}{An integer specifying the verbosity of logging (see \code{\link{setLogLevel.PhyloSim}}).}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# set.seed(1)
# ## The following examples demonstrate
# ## the typical use of the framework.
# ## See the package vignette and
# ## \url{http://github.com/bsipos/phylosim/tree/master/examples/}
#
# ## The ll() method gives information about the methods defined
# ## in the immediate class of an object.
# ## Useful when exploring the framework.
#
# s<-Sequence()
# ll(s)
# ll(PhyloSim())
# ll(GTR())
#
# ## Example 1 - A short simulation:
# ## simulate nucleotide seqeunces and display
# ## the resulting alignment matrix.
#
# Simulate(
# PhyloSim(phy=rcoal(3),
# root=NucleotideSequence(string="ATGC", proc=list(list(JC69())) ) )
# )$alignment
#
# # Construct a phylo object for the following
# # simulations, scale total tree length to 1:
#
# tmp<-PhyloSim(phylo=rcoal(3))
# scaleTree(tmp,1/tmp$treeLength)
# tmp$treeLength
# t<-tmp$phylo
#
# ## Example 3 - simulating rate variation,
# ## insertions and deletions.
# ## See the examples/example_3_clean.R file
# ## in the phylosim GitHub repository.
#
# # construct a GTR process object
# gtr<-GTR(
# name="MyGTR",
# rate.params=list(
# "a"=1, "b"=2, "c"=3,
# "d"=1, "e"=2, "f"=3
# ),
# base.freqs=c(2,2,1,1)/6
# )
# # get object summary
# summary(gtr)
# # display a bubble plot
# plot(gtr)
#
# # construct root sequence object
# s<-NucleotideSequence(length=20)
# # attach process via virtual field
# s$processes<-list(list(gtr))
# # sample states from the equilibrium
# # distribution of the attached processes
# sampleStates(s)
# # create among-site rate variation by sampling
# # the "rate.multiplier" site-process-specific parameter
# # from a discrete gamma distribution (GTR+G).
# plusGamma(s,gtr,shape=0.1)
# # make the range 11:12 invariable
# setRateMultipliers(s,gtr,0,11:12)
# # get the rate multipliers for s and gtr
# getRateMultipliers(s,gtr)
#
# construct a deletion process object
# # proposing lengths in the range 1:3
# d<-DiscreteDeletor(
# rate=0.1,
# name="MyDel",
# sizes=c(1:3),
# probs=c(3/6,2/6,1/6)
# )
# # get object
# summary(d)
# # plot deletion length distribution
# plot(d)
# # attach deletion process d to sequence s
# attachProcess(s,d)
# # create a region rejecting all deletions
# setDeletionTolerance(s,d,0,11:12)
#
# # construct an insertion process object
# # proposing lengths in the range 1:3
# i<-DiscreteInsertor(
# rate=0.1,
# name="MyDel",
# sizes=c(1:2),
# probs=c(1/2,1/2),
# template.seq=NucleotideSequence(length=1,processes=list(list(JC69())))
# )
# # states will be sampled from the JC69 equilibrium distribution
# # get object
# summary(i)
# # plot insertion length distribution
# plot(i)
# # attach insertion process i to sequence s
# attachProcess(s,i)
# # create a region rejecting all insertions
# setInsertionTolerance(s,i,0,11:12)
#
# # plot total site rates
# plot(s)
# # construct simulation object
# sim<-PhyloSim(root.seq=s, phylo=t)
# # get object summary
# summary(sim)
# # plot tree
# plot(sim)
# # run simulation
# Simulate(sim)
# # get the list of recorded per-branch event counts
# getBranchEvents(sim)
# # export the number of substitutions as a phylo object
# subst<-exportStatTree(sim,"substitution")
# # plot the exported phylo object
# plot(subst)
# # plot tree and alignment
# plot(sim)
# # save and display alingment
# file<-paste("PhyloSim_dummy_fasta_",Sys.getpid(),".fas",sep="");
# saveAlignment(sim,file=file);
# # print out the Fasta file
# cat(paste(scan(file=file,what=character(),sep="\n"),collapse="\n"));cat("\n");
# # delete Fasta file
# unlink(file);
#
# # See \url{http://github.com/bsipos/phylosim/tree/master/examples/examples_class.R}
# # for the full list of PhyloSim constructor examples.
#
# ## See the package vignette and
# ## the GitHub repository for even more examples.
# }
#
# @author
#
# \seealso{
# \code{\link{PSRoot} \link{Alphabet} \link{AminoAcidAlphabet}
# \link{AminoAcidSequence} \link{AminoAcidSubst}
# \link{AnyAlphabet} \link{BinaryAlphabet} \link{BinarySequence}
# \link{BinarySubst} \link{BrownianInsertor} \link{CodonAlphabet}
# \link{CodonSequence} \link{CodonUNREST} \link{ContinuousDeletor}
# \link{ContinuousInsertor} \link{cpREV} \link{DiscreteDeletor}
# \link{DiscreteInsertor} \link{Event} \link{F81} \link{F84}
# \link{FastFieldDeletor} \link{GeneralDeletor}
# \link{GeneralInDel} \link{GeneralInsertor} \link{GeneralSubstitution}
# \link{GTR} \link{GY94} \link{HKY} \link{JC69} \link{JTT} \link{JTT.dcmut}
# \link{K80} \link{K81} \link{LG} \link{mtArt} \link{mtMam} \link{mtREV24}
# \link{MtZoa} \link{NucleotideAlphabet} \link{NucleotideSequence} \link{PAM}
# \link{PAM.dcmut} \link{PhyloSim} \link{Process} \link{QMatrix} \link{Sequence}
# \link{Site} \link{T92} \link{TN93} \link{UNREST} \link{WAG}}
# }
#
#*/###########################################################################
setConstructorS3(
"PhyloSim",
function(
phylo=NA,
root.seq=NA,
name=NA,
log.file=NA,
log.level=-1, # no loggin is performed by default
...
) {
this<-PSRoot();
this<-extend(this,
"PhyloSim",
.name="Anonymous",
.phylo=NA,
.root.sequence=NA,
.sequences=list(), # references to the sequence objects
.node.hooks=list(), # references to the node hook functions.
.branch.stats=list(), # branch statistics.
.alignment=NA, # the resulting alignment in fasat format.
.log.file=NA, # the name of the log file.
.log.connection=NA, # connection for the log file.
.log.level=NA # log level
);
if(!all(is.na(phylo))){
this$phylo<-phylo;
}
if(!all(is.na(root.seq))){
this$rootSeq<-root.seq;
}
if(!missing(name)){
this$name<-name;
}
if(!missing(log.file)){
this$logFile<-log.file;
} else {
# Setting default log file:
tmp<-this$id;
tmp<-gsub(":","_",tmp);
this$logFile<-paste(tmp,".log",sep="");
}
# Setting log level:
this$logLevel<-log.level;
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="PhyloSim",
function(
this,
...
){
may.fail<-function(this) {
# Checking the name:
this$name<-this$name;
# Checking the phylo object:
if (!any(is.na(this$.phylo)) & !is.phylo(this$.phylo) ){
throw("The phylo object is invalid!\n");
}
# Checking the log level:
if(!is.numeric(this$.log.level) | (length(this$.log.level) != 1) ){
throw("The log level must be numeric vector of length 1!\n");
}
# Checking lof file:
if(!is.character(this$.log.file) | (length(this$.log.level) != 1) ){
throw("The log file must be charcter vector of length 1!\n");
}
# Checking the sequences:
for (seq in this$.sequences){
if(is.Sequence(seq)){
checkConsistency(seq);
}
}
# Checking node hooks:
for (hook in this$.node.hooks){
if(!is.null(hook) & !is.function(hook)){
throw("Invalid node hook found!\n");
}
}
# Checking the alignment:
if(!any(is.na(this$.alignment))){
.checkAlignmentConsistency(this, this$.alignment);
}
}
tryCatch(may.fail(this));
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
)
##
## Method: is.phylo.default
##
###########################################################################/**
#
# @RdocDefault is.phylo
#
# @title "Check if an object is an instance of the phylo class"
#
# \description{
# @get "title".
# Phylo objects are created by the \pkg{APE} package. This method just return the value of \code{inherits(this,"phylo")}.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # load APE
# library(ape);
# # create some objects
# o1<-Object();
# o2<-rcoal(3);
# # check if they are phylo objects
# is.phylo(o1);
# is.phylo(o2);
#
# }
#
# @author
#
# \seealso{
# The \pkg{ape} package.
# }
#
#*/###########################################################################
setMethodS3(
"is.phylo",
class="default",
function(
this,
...
){
inherits(this,"phylo");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
)
##
## Method: setPhylo
##
###########################################################################/**
#
# @RdocMethod setPhylo
#
# @title "Set the phylo object for a PhyloSim object"
#
# \description{
# @get "title".
#
# The internal structure of the provided phylo object is reordered in a cladeweise fashion.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{value}{A phylo object created by the \pkg{ape} package.}
# \item{...}{Not used.}
# }
#
# \value{
# A phylo object or FALSE.
# }
#
# \examples{
# #create a PhyloSim object
# sim<-PhyloSim();
# # creat a phylo object
# tree<-rcoal(3);
# # get/set phylo object
# setPhylo(sim,tree);
# getPhylo(sim,tree);
# # get/set phylo object via virtual field
# sim$tree<-rcoal(5);
# sim$tree;
# }
#
# @author
#
# \seealso{
# The PhyloSim class, the \pkg{ape} package.
# }
#
#*/###########################################################################
setMethodS3(
"setPhylo",
class="PhyloSim",
function(
this,
value,
...
){
if(missing(value)){
throw("No object provided!\n");
}
else if(!is.phylo(value)){
throw("The new value must be a \"phylo\" object!\n");
}
else if(!is.rooted(value)){
throw("The new value must be a rooted \"phylo\" object!\n");
}
else {
.checkTipLabels(value);
this$.phylo<-value;
this$.phylo<-reorder(this$.phylo, order="cladewise");
for (i in this$nodes){
this$.sequences[[i]]<-NA;
}
return(this$.phylo);
}
return(FALSE);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkTipLabels
##
setMethodS3(
".checkTipLabels",
class="phylo",
function(
this,
...
){
for(label in this$tip.label){
if(length(grep("^Node \\d+$",label,perl=TRUE,value=FALSE)) > 0){
throw("Sorry, but the node labels matching \"Node \\d+\" are reserved for internal nodes! Blaming label: ",label,".\n");
}
else if(length(grep("^Root node \\d+$",label,perl=TRUE,value=FALSE)) > 0){
throw("Sorry, but the node labels matching \"Root node \\d+\" are reserved for the root node! Blaming label: ",label,".\n");
}
}
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
)
##
## Method: getPhylo
##
###########################################################################/**
#
# @RdocMethod getPhylo
#
# @title "Get the phylo object aggregated in a PhyloSim object"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A phylo object or NA.
# }
#
# \examples{
# #create a PhyloSim object
# sim<-PhyloSim();
# # creat a phylo object
# tree<-rcoal(3);
# # get/set phylo object
# setPhylo(sim,tree);
# getPhylo(sim,tree);
# # get/set phylo object via virtual field
# sim$tree<-rcoal(5);
# sim$tree;
# }
#
# @author
#
# \seealso{
# The PhyloSim class, the \pkg{ape} package.
# }
#
#*/###########################################################################
setMethodS3(
"getPhylo",
class="PhyloSim",
function(
this,
...
){
this$.phylo;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
)
##
## Method: setRootSeq
##
###########################################################################/**
#
# @RdocMethod setRootSeq
#
# @title "Set the root sequence for a PhyloSim object"
#
# \description{
# @get "title".
#
# The root sequence will be used as a starting point for the simulation. The phylo object must be set before
# trying to set the root sequence object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{value}{A valid Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# The root Sequence object if succesfull, FALSE otherwise.
# }
#
# \examples{
# # create some objects
# sim<-PhyloSim(phylo=rcoal(3));
# seq<-NucleotideSequence(string="ATGCC");
# # set/get root sequence
# setRootSeq(sim, seq);
# getRootSeq(sim, seq);
# # set/get root sequence via virtual field
# sim$rootSeq<-BinarySequence(string="111000111000");
# sim$rootSeq;
#
# }
#
# @author
#
# \seealso{
# @seeclass Sequence Process
# }
#
#*/###########################################################################
setMethodS3(
"setRootSeq",
class="PhyloSim",
function(
this,
value,
...
){
if(missing(value)){
throw("No object provided!\n");
}
else if(!is.Sequence(value)){
throw("The new value must be a sequence object!\n");
}
else {
this$.root.sequence<-clone(value);
this$.root.sequence$name<-paste("Root node",this$rootNode);
# Call garbage collection:
gc();
gc();
return(this$.root.sequence);
}
return(FALSE);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
)
##
## Method: getRootSeq
##
###########################################################################/**
#
# @RdocMethod getRootSeq
#
# @title "Get the root sequence aggregated by a PhyloSim object"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# The root Sequence object or NA.
# }
#
# \examples{
# # create some objects
# sim<-PhyloSim(phylo=rcoal(3));
# seq<-NucleotideSequence(string="ATGCC");
# # set/get root sequence
# setRootSeq(sim, seq);
# getRootSeq(sim, seq);
# # set/get root sequence via virtual field
# sim$rootSeq<-BinarySequence(string="111000111000");
# sim$rootSeq;
#
# }
#
# @author
#
# \seealso{
# @seeclass Sequence Process
# }
#
#*/###########################################################################
setMethodS3(
"getRootSeq",
class="PhyloSim",
function(
this,
...
){
this$.root.sequence;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
)
##
## Method: as.character.PhyloSim
##
###########################################################################/**
#
# @RdocMethod as.character
#
# @title "Return the character representation of a PhyloSim object"
#
# \description{
# @get "title".
#
# The character representation is the identifier of the PhyloSim object as returned by the \code{getId} method.
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a PhyloSim object
# o<-PhyloSim(name="MySim");
# # get character representation
# as.character(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"as.character",
class="PhyloSim",
function(
x,
...
){
return(getId(x));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
)
##
## Method: getName
##
###########################################################################/**
#
# @RdocMethod getName
#
# @title "Get the name of a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a PhyloSim object
# o<-PhyloSim();
# # set/get name
# setName(o,"MySim");
# getName(o,"MySim");
# # set/get name via virtual field
# o$name<-"George";
# o$name
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getName",
class="PhyloSim",
function(
this,
...
){
this$.name;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setName
##
###########################################################################/**
#
# @RdocMethod setName
#
# @title "Set the name of a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{new.name}{A character vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new name.
# }
#
# \examples{
# # create a PhyloSim object
# o<-PhyloSim();
# # set/get name
# setName(o,"MySim");
# getName(o,"MySim");
# # set/get name via virtual field
# o$name<-"George";
# o$name
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setName",
class="PhyloSim",
function(
this,
new.name,
...
){
this$.name<-as.character(new.name);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getId
##
###########################################################################/**
#
# @RdocMethod getId
#
# @title "Get the unique identifier of a PhyloSim object"
#
# \description{
# @get "title".
# The unique identifier is the concatenation of the class, the object name as returned by getName() and the object hash
# as returned by hashCode().
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a PhyloSim object
# o<-PhyloSim(name="MySim");
# # get id
# getId(o);
# # get id via virtual field
# o$id;
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getId",
class="PhyloSim",
function(
this,
...
){
this.class<-class(this)[1];
id<-paste(this.class,this$.name,hashCode(this),sep=":");
return(id);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setId
##
###########################################################################/**
#
# @RdocMethod setId
#
# @title "Forbidden action: setting the unique identifier of a PhyloSim object"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setId",
class="PhyloSim",
function(
this,
value,
...
){
throw("Id is generated automatically and it cannot be set!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: Simulate
##
###########################################################################/**
#
# @RdocMethod Simulate
#
# @title "Run a simulation according to a PhyloSim object"
#
# \description{
# @get "title".
#
# The phylo object and the root sequence must be set before attempting to run a simulation.
# Also the bigRate of the root sequence must not be NA or zero, so at least one sane
# Process object must be attached to the root sequence object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{quiet}{TRUE or FALSE (default).}
# \item{...}{Not used.}
# }
#
# \value{
# The PhyloSim object (invisible).
# }
#
# \examples{
# # Create a PhyloSim object.
# # Provide the phylo object
# # and the root sequence.
# sim<-PhyloSim(
# name="TinySim",
# phylo=rcoal(3),
# root.seq=NucleotideSequence(string="ATGC",processes=list(list(JC69())))
# );
# # Run the simulation
# Simulate(sim);
# # Print the resulting sequences
# sim$sequences
# # Print the resulting alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"Simulate",
class="PhyloSim",
function(
this,
quiet=FALSE,
...
){
if(!is.phylo(this$.phylo)){
throw("Cannot simulate because the phylo object is not set or it is invalid!\n");
}
# Check for the root sequence:
else if(!is.Sequence(this$.root.sequence)){
throw("Cannot simulate because the root sequence is not set or it is invalid!\n");
}
# Check bigRate validity:
else if(is.na(this$.root.sequence$bigRate)){
throw("Cannot simulate because the bigRate of the root sequence is NA!\n");
}
else{
# Warn for zero bigRate:
if(this$.root.sequence$bigRate == 0){
warning("The bigRate of the root sequence is zero! You are running a pointless simulation!\n");
}
if(exists(x="PSIM_FAST")){
if(!quiet){
cat("!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n");
cat("!! WARNING: fast & careless mode is on, most of the error checking is omitted! !!\n");
cat("!! Please note that this also disables the saving of branch statistics. !!\n");
cat("!! You can go back to normal mode by deleting the PSIM_FAST object. !!\n");
cat("!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\n");
}
Log(this,"WARNING: fast & careless mode is on, most of the error checking is omitted!");
}
# Attach root sequence to root node:
Log(this,paste("Attaching root sequence ",this$.root.sequence$id,sep=""));
attachSeqToNode(this, node=getRootNode(this),seq=this$.root.sequence);
# Write protecting the root sequence:
Log(this,paste("Write protecting root sequence ",this$.root.sequence$id,sep=""));
this$.root.sequence$writeProtected<-TRUE;
# Traverse the tree and simulate:
Log(this,paste("Starting simulation on the object",this$id));
edge.counter<-1;
n.edges<-this$nedges;
for(edge in 1:n.edges){
if(!quiet){ cat("Simulating edge",edge,"of", n.edges,"\n");}
Log(this,paste("Starting to simulate edge",edge,"of",n.edges));
.simulateEdge(this,number=edge);
edge.counter<-edge.counter+1;
}
}
Log(this, "Simulation finished, building alignment!\n");
this$.alignment<-.recoverAlignment(this);
# Flush the log connection:
if(!is.na(this$.log.connection)){
close(this$.log.connection);
}
# Call the garbage collector:
gc();
gc();
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .simulateEdge
##
setMethodS3(
".simulateEdge",
class="PhyloSim",
function(
this,
number=NA,
...
){
# Get edge:
edge<-getEdge(this, number);
# Get parent node:
start.seq<-getSeqFromNode(this, edge[[1,"from"]]);
# Evolve sequence:
new.seq<-.evolveBranch(this, start.seq=start.seq, branch.length=edge[1,"length"], old.node=edge[[1,"from"]],new.node=edge[[1,"to"]], branch.number=number);
# Write protect the sequence:
new.seq$writeProtected<-TRUE;
# Attach sequence to children node:
attachSeqToNode(this, node=edge[1,"to"], seq=new.seq);
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .evolveBranch
##
setMethodS3(
".evolveBranch",
class="PhyloSim",
function(
this,
start.seq=NA,
branch.length=NA,
old.node=NA,
new.node=NA,
branch.number=NA,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(start.seq)){
throw("No starting sequence provided!\n");
}
else if(missing(branch.length)){
throw("No branch length provided!\n");
}
else if(!is.numeric(branch.length)){
throw("The branch length must be numeric!\n");
}
}
if(.checkSeq(this, start.seq) ){
# Cloning the starting sequence:
seq<-clone(start.seq);
# Set the name of the sequence object:
if(is.tip(this, new.node)){
seq$name<-this$tipLabels[[new.node]];
}
else {
seq$name<-paste("Node",new.node);
}
.GillespieDirect(this, seq=seq, branch.length=branch.length, branch.number=branch.number);
# Call the node hook if exists:
hook<-this$.node.hooks[[as.character(new.node)]];
if(!is.null(hook) & is.function(hook)){
Log(this,paste("Calling node hook for node",new.node));
seq<-hook(seq=seq);
if(!is.Sequence(seq)){
throw("Node hook returned an invalid sequence object!\n");
}
else if(is.na(seq$bigRate)){
throw("Node hook returned sequence with NA bigRate!\n");
}
else if(seq$bigRate == 0.0){
throw("Node hook returned sequence with zero bigRate!\n");
}
else{
checkConsistency(seq, omit.sites=TRUE);
}
}
# Return the resulting sequence object:
return(seq);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .GillespieDirect
##
setMethodS3(
".GillespieDirect",
class="PhyloSim",
function(
this,
seq=NA,
branch.length=NA,
branch.number=NA,
...
){
Debug(this, paste("Branch length is",branch.length));
# Initialize time:
time<-0.0;
# Sample the next waiting time until
# the branch length is consumed:
while( (time<-time + rexp(n=1, rate=(big.rate<-getBigRate(seq)))) <= branch.length){
# Generate a random number between zero and the bigRate:
E<-runif(n=1,min=0,max=big.rate);
# Identify the target site:
site.number<-which(.getCumulativeRatesFast(seq) >= E)[[1]];
# Get the events from the target site:
site<-seq$.sites[[site.number]];
site$.position<-site.number;
events<-getEvents(site);
site$.position<-NULL;
# Get the rates:
rates<-double();
for(e in events){
rates<-c(rates,e$.rate);
}
# Calculate the corresponding cumulative rates:
if(site.number > 1){
rates<-cumsum(c(seq$.cumulative.rates[[site.number - 1]], rates));
}
else {
rates<-cumsum(c(0.0, rates));
}
# Pick the event:
event.number<-which(rates >= E)[[1]] - 1;
event<-events[[event.number]];
# Log the event:
Log(this,paste("Performing event [",event$.name,"] at position",event$.position,"generated by the process",event$.process$.id));
# Perform the event:
event.details<-Perform(event);
Debug(this,paste("Remaining branch length is",(branch.length-time) ));
# Log event details:
# Log deletion event details:
if(event$.name == "Deletion"){
Log(this,paste("The process",event$.process,"proposed to delete range",paste(event.details$range,collapse="--"),". Accepted:",event.details$accepted));
}
# Log insertion event details:
else if(event$.name == "Insertion"){
message<-paste("The process ",event$.process," proposed insertion at position ",event.details$position,". Accepted: ",event.details$accepted,sep="");
if(event.details$accepted == TRUE){
message<-paste(message,"."," Insert length was ",event.details$length,sep="");
}
Log(this, message);
}
# Update branch statistics if not in fast mode:
if(!exists(x="PSIM_FAST")){
.UpdateBranchStats(this,event,event.details, branch.number);
}
# Abort if sequence length shrunk to zero:
if(seq$.length == 0){
message<-paste("Terminating the simulation because the length of the sequence ",seq$name," shrunk to zero! Please be more careful when tuning the indel rates!\n");
Log(this, message);
throw(message);
}
} #/while
# Calling garbage collection:
gc();
gc();
return(seq);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: attachSeqToNode
##
###########################################################################/**
#
# @RdocMethod attachSeqToNode
#
# @title "Assotiate a Sequence object with a given node of a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
#
# This method is mainly used internally.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{node}{Node identifier.}
# \item{seq}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# The PhyloSim object (invisible).
# }
#
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"attachSeqToNode",
class="PhyloSim",
function(
this,
node=NA,
seq=NA,
...
){
if(!is.phylo(this$.phylo)){
throw("The phylo object is not set, sequence to node is not possible!\n");
}
if(missing(node)){
throw("No node specified!\n");
}
else if(missing(seq)){
throw("No sequence object given");
}
else if(.checkNode(this,node) & .checkSeq(this, seq)){
if(is.Sequence(this$.sequences[[node]])){
throw("The node has already an attached sequence. Detach that before trying to attach a new one!\n");
}
else {
this$.sequences[[as.numeric(node)]]<-seq;
return(invisible(this));
}
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: attachHookToNode
##
###########################################################################/**
#
# @RdocMethod attachHookToNode
#
# @title "Attach a callback function to a given node of a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
#
# A "node hook" is a function which accepts a Sequence object through the named argument "seq" and returns a
# Sequence object. The node hook function must accept any object which inherits from the \code{Sequence} class!
#
# After simulating the branch leading to the node, the resulting Sequence object is passed
# to the node hook and the returned object is used to simulate the downstream branches.
#
# By using node hooks the attached processes can be replaced during simulation, hence enabling the simulation of
# non-homogeneous sequence evolution.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{node}{Node identifier.}
# \item{fun}{A function (see above).}
# \item{...}{Not used.}
# }
#
# \value{
# The PhyloSim object (invisible).
# }
#
# \examples{
# # Create a PhyloSim object.
# # Provide the phylo object
# # and the root sequence.
# sim<-PhyloSim(
# name="TinySim",
# phylo=rcoal(3),
# root.seq=NucleotideSequence(string="ATGC",processes=list(list(JC69())))
# );
# # create a node hook function
# hook<-function(seq=NA){
# # replace the substitution process with F84
# if(inherits(seq,"NucleotideSequence")){
# cat("Replacing JC69 with F84.\n");
# seq$processes<-list(list(F84(rate.params=list("Kappa" = 2))));
# }
# return(seq);
# }
# # attach hook function to node 5
# attachHookToNode(sim,5,hook);
# # Run the simulation
# Simulate(sim);
# # Check if the processes have been truly replaced
# lapply(sim$sequences, getUniqueProcesses.Sequence)
# # Print the resulting alignment
# sim$alignment
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"attachHookToNode",
class="PhyloSim",
function(
this,
node=NA,
fun=NA,
...
){
if(!is.phylo(this$.phylo)){
throw("The phylo object is not set, attaching node hook is not possible!\n");
}
if(missing(node)){
throw("No node specified!\n");
}
else if(missing(fun)){
throw("No function given!");
}
else if(!is.function(fun)){
throw("The argument \"fun\" must be a function!\n");
}
else if( length(intersect(names(formals(fun)), "seq")) == 0 ){
throw("The function argument must have a an argument named \"seq\"");
}
else if(!is.Sequence(fun(Sequence(length=1)))){
throw("The insert hook function must return a Sequence object!\n");
}
else if( .checkNode(this,node) ){
if(is.function(this$.node.hooks[[as.character(node)]])){
throw("The node has already an attached node hook. Detach that before trying to attach a new one!\n");
}
else {
this$.node.hooks[[as.character(node)]]<-fun;
return(invisible(this));
}
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkNode
##
setMethodS3(
".checkNode",
class="PhyloSim",
function(
this,
node=NA,
...
){
if(missing(node)){
throw("No node specified!\n");
} else if( length(intersect(node, getNodes(this))) != 1){
throw("The specified node is invalid!\n");
}
else {
return(TRUE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkSeq
##
setMethodS3(
".checkSeq",
class="PhyloSim",
function(
this,
seq=NA,
...
){
if(missing(seq)){
throw("No sequence specified!\n");
} else if(!is.Sequence(seq)){
throw("The sequence object is invalid!\n");
}
else {
return(TRUE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: detachSeqFromNode
##
###########################################################################/**
#
# @RdocMethod detachSeqFromNode
#
# @title "Detach a Sequence object from a given node of a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
#
# This method is mainly used internally.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{node}{Node identifier.}
# \item{...}{Not used.}
# }
#
# \value{
# The PhyloSim object (invisible).
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"detachSeqFromNode",
class="PhyloSim",
function(
this,
node=NA,
...
){
if(missing(node)){
throw("No node specified!\n");
}
else if( .checkNode(this,node) ){
this$.sequences[[as.numeric(node)]]<-NA;
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: detachHookFromNode
##
###########################################################################/**
#
# @RdocMethod detachHookFromNode
#
# @title "Detach a node hook function from a given node of a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{node}{Node identifier.}
# \item{...}{Not used.}
# }
#
# \value{
# The PhyloSim object (invisible).
# }
#
# \examples{
# # Create a PhyloSim object.
# # Provide the phylo object
# # and the root sequence.
# sim<-PhyloSim(
# name="TinySim",
# phylo=rcoal(3),
# root.seq=NucleotideSequence(string="ATGC",processes=list(list(JC69())))
# );
# # create a node hook function
# hook<-function(seq=NA){
# # replace the substitution process with F84
# if(inherits(seq,"NucleotideSequence")){
# cat("Replacing JC69 with F84.\n");
# seq$processes<-list(list(F84(rate.params=list("Kappa" = 2))));
# }
# return(seq);
# }
# # attach hook function to node 5
# attachHookToNode(sim,5,hook);
# # detach hook from node 5
# detachHookFromNode(sim,5);
# # Run the simulation again
# Simulate(sim); # You should not see the message printed out by the "hook" function.
#
# }
#
# @author
#
# \seealso{
# attachHookToNode PhyloSim Simulate.PhyloSim
# }
#
#*/###########################################################################
setMethodS3(
"detachHookFromNode",
class="PhyloSim",
function(
this,
node=NA,
...
){
if(missing(node)){
throw("No node specified!\n");
}
else if( .checkNode(this,node) ){
this$.node.hooks[[as.character(node)]]<-NA;
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSeqFromNode
##
###########################################################################/**
#
# @RdocMethod getSeqFromNode
#
# @title "Get the Sequence object associated with a given node of a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{node}{Node identifier.}
# \item{...}{Not used.}
# }
#
# \value{
# A Sequence object.
# }
#
# \examples{
# # Create a PhyloSim object.
# # Provide the phylo object
# # and the root sequence.
# sim<-PhyloSim(
# name="TinySim",
# phylo=rcoal(3),
# root.seq=NucleotideSequence(string="ATG",processes=list(list(JC69())))
# );
# # get the sequence associated with node 5
# getSeqFromNode(sim,5) # Should be NA
# # Run the simulation
# Simulate(sim)
# # try again
# getSeqFromNode(sim,5)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSeqFromNode",
class="PhyloSim",
function(
this,
node=NA,
...
){
if(missing(node)){
throw("No node specified!\n");
}
else if( .checkNode(this,node) ){
return(this$.sequences[[as.numeric(node)]]);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSequences
##
###########################################################################/**
#
# @RdocMethod getSequences
#
# @title "Gets all the Sequence objects associated with the nodes of a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
#
# The order of the Sequence objects in the returned list reflects the identifiers of the associated nodes.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of sequence objects.
# }
#
# \examples{
# # Create a PhyloSim object.
# # Provide the phylo object
# # and the root sequence.
# sim<-PhyloSim(
# name="TinySim",
# phylo=rcoal(3),
# root.seq=NucleotideSequence(string="ATG",processes=list(list(JC69())))
# );
# # run the simulation
# Simulate(sim)
# # get all the associated sequence objects
# getSequences(sim)
# # get the sequence associated with node 3
# # via virtual field
# sim$sequences[[3]]
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSequences",
class="PhyloSim",
function(
this,
...
){
slist<-list();
for (node in getNodes(this)){
slist[[node]]<-getSeqFromNode(this, node=node);
}
return(slist);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setSequences
##
###########################################################################/**
#
# @RdocMethod setSequences
#
# @title "Forbidden action: setting the Sequence objects associated with the nodes of a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setSequences",
class="PhyloSim",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAlignment
##
###########################################################################/**
#
# @RdocMethod getAlignment
#
# @title "Get the alignment stored in a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# The alignment as a matrix. Gap are represented by strings composed of dashes.
# }
#
# \examples{
# # Create a PhyloSim object.
# # Provide the phylo object
# # and the root sequence.
# sim<-PhyloSim(
# name="TinySim",
# phylo=rcoal(3),
# root.seq=NucleotideSequence(string="ATG",processes=list(list(JC69())))
# );
# # run the simulation
# Simulate(sim)
# # get the resulting aligment
# getAlignment(sim)
# # via virtual fileld:
# sim$alignment
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAlignment",
class="PhyloSim",
function(
this,
...
){
this$.alignment;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setAlignment
##
###########################################################################/**
#
# @RdocMethod setAlignment
#
# @title "Forbidden action: setting the alignment stored in a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setAlignment",
class="PhyloSim",
function(
this,
value,
...
){
this$alignment <- value;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .recoverAlignment
##
setMethodS3(
".recoverAlignment",
class="PhyloSim",
function(
this,
paranoid=FALSE,
...
){
# Refuse to build alignment if at least one of the sequences is NA:
for (seq in this$.sequences){
if(!is.Sequence(seq)){
throw("Cannot build alignment because the simulation is incomplete!\n");
}
}
# The list holding all the partial alignment matrices:
aln.mat<-list();
# Assigning NA-s here to prevent creation of these variables in the global
# environment.
row.names<-NA;
from.node<-NA;
to.node<-NA;
from.seq<-NA;
to.seq<-NA;
edge<-NA;
from.name<-NA;
to.name<-NA;
from.mat<-NA;
to.mat<-NA;
# Initialize the variables:
init.vars<-function(){
# Getting the edge:
edge<<-getEdge(this, edge.number);
# Getting the nodes:
from.node<<-edge[[1,"from"]];
to.node<<-edge[[1,"to"]];
# Getting the sequence objects:
from.seq<<-getSeqFromNode(this, from.node)
to.seq<<-getSeqFromNode(this, to.node)
# Getting sequence names:
from.name<<-from.seq$name;
to.name<<-to.seq$name;
}
# Initialize the aligment matrices:
init.aln.mats<-function(){
# Initialize "from" element in aln.mat if necessary:
if( is.null(aln.mat[[from.name]] )){
# Create a row of the states:
tmp<-rbind(as.character(lapply(from.seq$.sites, getState)));
# Label the columns by the site position:
colnames(tmp)<-seq(along.with=from.seq$.sites);
# Label the row with the sequence name:
rownames(tmp)<-from.name;
# Set the corresponding list element in aln.mat:
aln.mat[[ from.name ]]<-tmp;
}
# Set from.mat
from.mat<<-aln.mat[[ from.name ]];
# Initialize "to" element int aln.mat if necessary
if( is.null(aln.mat[[to.name]]) ){
# Create a new entry if we are dealing with a tip:
if(is.tip(this, to.node)){
# Create a vector of states:
tmp<-rbind(as.character(lapply(to.seq$.sites, getState)));
# Label columns by position:
colnames(tmp)<-seq(along.with=to.seq$.sites);
# Label row by sequence name:
rownames(tmp)<-to.name;
aln.mat[[ to.name ]]<-tmp;
}
else {
# A "to" element can be null only if its a tip:
throw("aln.mat inconsistency!\n");
}
}
# Set to.mat:
to.mat<<-aln.mat[[ to.name ]];
# Save row names:
# The order is important! First "from", than "to"!
row.names<<-c(rownames(from.mat), rownames(to.mat));
}
# Get the sequence position of a given alignment column from
# the column labels:
get.seq.pos<-function(mat=NA, col=NA){
# Column number cannot be larger than length:
if(col > dim(mat)[[2]]){
throw("Invalid column number!\n");
}
# Get the corresponding column name:
tmp<-colnames(mat)[[col]];
# Return if NA:
if(is.na(tmp)){
return(NA);
}
else{
return(as.numeric(tmp));
}
}
# Check if two positions from the two *sequences* are homologous.
is.homologous<-function(from.pos=NA, to.pos=NA){
# Check position validity:
if(to.pos > to.seq$length){
throw("to.pos too big ",to.pos);
}
if(from.pos > from.seq$length){
throw("from.pos too big ",from.pos);
}
# Check if the ancestral from to.seq/to.pos is from.seq/from.pos:
return(equals(to.seq$.sites[[ to.pos ]]$.ancestral, from.seq$.sites[[ from.pos ]]));
}
# Get the symbol length from "to.seq" at position to.pos:
get.to.symlen<-function(pos=NA){
len<-stringLength(to.mat[to.name , pos]);
if( is.na(len) | (len < 1) ){
throw("Trouble in getting to.symlen!");
} else {
return(len);
}
}
# Get the symbol length from "from.seq" at position from.pos:
get.from.symlen<-function(pos=NA){
len<-stringLength(from.mat[from.name , pos]);
if( is.na(len) | (len < 1) ){
throw("Trouble in getting from.symlen!");
} else {
return(len);
}
}
make.gap.in.from<-function(label=NA,symlen=NA){
# Create the gap symbol:
gap<-paste(rep("-",times=symlen),collapse="");
# Create the vector with gaps:
gaps<-cbind(rep(gap, times=dim(from.mat)[[1]] ));
# Label the column:
colnames(gaps)<-c(label);
# Bind the gaps with the corresponding column from to.mat,
# and than bind with res.mat:
res.mat<<-cbind(res.mat, rbind( gaps, cbind(to.mat[,j]) ) );
# Restore rownames:
rownames(res.mat)<<-row.names;
# Increment counter for to.mat:
j<<-j+1;
}
make.gap.in.to<-function(label=NA,symlen=NA){
# See above.
gap<-paste(rep("-",times=symlen),collapse="");
gaps<-cbind(rep(gap, times=dim(to.mat)[[1]] ));
colnames(gaps)<-c(label);
res.mat<<-cbind(res.mat, rbind( cbind(from.mat[,i]), gaps ) );
rownames(res.mat)<<-row.names;
i<<-i+1;
}
emmit.homologous<-function(){
# Bind the two columns into one column:
tmp<-cbind(rbind( cbind(from.mat[,i]), cbind(to.mat[,j]) ) );
# Label the column by from.pos:
colnames(tmp)<-c(from.pos);
# Set res.mat
res.mat<<-cbind(res.mat, tmp );
# resotre rownames:
rownames(res.mat)<<-row.names;
i<<-i+1;
j<<-j+1;
}
# Iterate over the reverse of the edge matrix:
for (edge.number in rev(seq(from=1, to=this$nedges))){
# Call variable initialization:
init.vars();
# Initialize partial alignment matrices:
init.aln.mats();
# The matrix holding the resulting partial alignment:
res.mat<-c();
# Column counter for from.mat:
i<-1;
# Column counter for to.mat:
j<-1;
while(i <=dim(from.mat)[[2]] | j <=dim(to.mat)[[2]] ){
# First of all, check for counter overflow:
if(i > dim(from.mat)[[2]]){
# If i is greater than the length of from.mat, but we
# are still iterating, that means that we have parts left from
# to.mat, so we have to create gaps in from.mat, and increment j.
make.gap.in.from(symlen=get.to.symlen(pos=j));
next();
}
else if (j > dim(to.mat)[[2]]){
# If j is greater than the length of to.mat and we still iterating,
# that means that we have still some columns in from.mat, so we create
# gaps in to.mat and increment i. We label the new column with from.pos.
from.pos<-get.seq.pos(mat=from.mat, col=i);
make.gap.in.to(label=from.pos,get.from.symlen(pos=i));
next();
}
# Now figure out the positions:
from.pos<-get.seq.pos(mat=from.mat, col=i);
to.pos<-get.seq.pos(mat=to.mat, col=j);
# Now check for the gaps wich have been introduced before:
if(is.na(from.pos)){
# If we have a gap in from.mat,
# than emmit the columnt with a gap in "to":
make.gap.in.to(symlen=get.from.symlen(pos=i));
next();
}
if(is.na(to.pos)){
# Existent gap in to.mat:
make.gap.in.from(symlen=get.to.symlen(pos=j));
next();
}
# Now we have some real alignment to do here:
if(is.homologous(from.pos=from.pos, to.pos=to.pos)){
# We have to homologous columns, bind them, and emmit:
emmit.homologous();
next();
}
else if(is.Process(to.seq$.sites[[to.pos]]$.ancestral)){
# The two columns are not homologous. The column in "to"
# was inserted by a process. Make gap in from:
make.gap.in.from(symlen=get.from.symlen(pos=i));
next();
}
else {
# The only possibility left is a deletion in the child sequence.
# Make gaps in "to", label new column by from.pos:
make.gap.in.to(label=from.pos,symlen=get.from.symlen(pos=i));
next();
}
} # while i | j
# Replace the "from" element in aln.mat with the resulting partial
# alignment matrix:
aln.mat [[ from.name ]]<-res.mat;
} # for edge.number
alignment <-aln.mat[[ this$rootSeq$name ]];
# Check the correcteness of the alignment if paranoid:
if(paranoid){
.checkAlignmentConsistency(this, alignment);
}
# Call garbage collection:
gc();
gc();
# The whole alignment is associated with the root node:
return(alignment);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkAlignmentConsistency
##
setMethodS3(
".checkAlignmentConsistency",
class="PhyloSim",
function(
this,
aln,
...
){
# First check if the sequences are intact:
for(node in this$nodes){
seq.node<-getSeqFromNode(this, node);
seq.aln<-aln[seq.node$name, ];
seq.aln<-seq.aln[ grep("^[^-]+$",seq.aln) ];
seq.aln<-paste(seq.aln, collapse="");
if(seq.aln != seq.node$string){
throw("The alignment is inconsistent with the sequence objects!\n Blaming ",seq.node$name, ".\n");
}
}
for(edge.number in rev(seq(from=1, to=this$nedges))){
# Getting the edge:
edge<-getEdge(this, edge.number);
# Getting the nodes:
from.node<-edge[[1,"from"]];
to.node<-edge[[1,"to"]];
# Getting the sequence objects:
from.seq<-getSeqFromNode(this, from.node)
to.seq<-getSeqFromNode(this, to.node)
# Getting sequence names:
from.name<-from.seq$name;
to.name<-to.seq$name;
# Initializing positions:
from.pos<-1;
to.pos<-1;
is.gap<-function(string){
res<-length(grep("^-+$",string));
if( res == 1 ){
return(TRUE);
}
else if (res > 1){
throw("is.gap: argument vector too long!\n");
}
else {
return(FALSE);
}
}
# Iterate over edges:
for (i in 1:dim(aln)[[2]]){
# Overflow in "from" counter,
if(from.pos > from.seq$length){
to.char<-aln[to.name,i];
if(!is.gap(to.char)){
# we have a final insertion:
if(!is.Process(to.seq$.sites[[to.pos]]$.ancestral)){
throw("Alignment insertion inconsistency!\n");
}
to.pos<-to.pos+1;
}
next();
}
# Overflow in "to" counter (final deletion):
if(to.pos > to.seq$length){
break();
}
# Get the symbols from alignment:
from.char<-aln[from.name,i];
to.char<-aln[to.name,i];
is.gap.to<-is.gap(to.char);
is.gap.from<-is.gap(from.char);
# Skip if we have to gap symbols:
if( is.gap.from & is.gap.to ){
next();
}
# Deletion in to.seq:
else if(is.gap.to & !is.gap.from ){
from.pos<-(from.pos+1);
}
# Insertion in to.seq:
else if(!is.gap.to & is.gap.from ){
# Check ancestral pointer for inserted sites:
if(!is.Process(to.seq$.sites[[to.pos]]$.ancestral)){
throw("Alignment insertion inconsistency!\n");
}
to.pos<-(to.pos+1);
} else {
# We must have a homology here:
if(!equals(to.seq$.sites[[ to.pos ]]$.ancestral, from.seq$.sites[[ from.pos ]])){
throw("Non-homologous sites aligned! Alignment is inconsistent!\n");
}
from.pos<-(from.pos+1);
to.pos<-(to.pos+1);
}
}
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: saveAlignment
##
###########################################################################/**
#
# @RdocMethod saveAlignment
#
# @title "Save the alignment stored in a PhyloSim object in a Fasta file"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{file}{The name of the output file.}
# \item{skip.internal}{Do not save sequences corresponding to internal nodes.}
# \item{paranoid}{Check the consistency of the alignment.}
# \item{...}{Not used.}
# }
#
# \value{
# The PhyloSim object (invisible).
# }
#
# \examples{
# # Create a PhyloSim object.
# # Provide the phylo object
# # and the root sequence.
# sim<-PhyloSim(
# name="TinySim",
# phylo=rcoal(3),
# root.seq=NucleotideSequence(string="ATG",processes=list(list(JC69())))
# );
# # run the simulation
# Simulate(sim)
# # save the alignment
# file<-paste("PhyloSim_dummy_fasta_",Sys.getpid(),".fas",sep="");
# saveAlignment(sim,file=file,paranoid=TRUE);
# # print out the Fasta file
# cat(paste(scan(file=file,what=character(),sep="\n"),collapse="\n"));cat("\n");
# # delete Fasta file
# unlink(file);
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"saveAlignment",
class="PhyloSim",
function(
this,
file="phylosim.fas",
skip.internal=FALSE,
paranoid=FALSE,
...
){
if(any(is.na(this$.alignment))){
warning("Alignment is undefined, nothin to save!\n");
return();
}
else {
if(paranoid){
.checkAlignmentConsistency(this, this$.alignment);
}
sink(file);
if(!skip.internal){
for(i in 1:dim(this$.alignment)[[1]]){
cat(">",rownames(this$.alignment)[[i]],"\n");
cat(paste(this$.alignment[i,],collapse=""),"\n");
}
} else {
for(i in 1:dim(this$.alignment)[[1]]){
name<-rownames(this$.alignment)[[i]];
if(!any((length(grep("^Node \\d+$",name,perl=TRUE,value=FALSE)) > 0),(length(grep("^Root node \\d+$",name,perl=TRUE,value=FALSE)) > 0))){
cat(">",name,"\n");
cat(paste(this$.alignment[i,],collapse=""),"\n");
}
}
}
sink(NULL);
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: plot.PhyloSim
##
###########################################################################/**
#
# @RdocMethod plot
#
# @title "Plot a PhyloSim object"
#
# \description{
# @get "title".
#
# This method plots the aggregated alignment alongside the tree used for simulation. Various options
# allow for control over the plot style.
#
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A PhyloSim object.}
# \item{plot.tree}{Whether to plot the tree alongside the alignment. TRUE or FALSE; defaults to TRUE.}
# \item{plot.ancestors}{Whether to plot the ancestral sequences. TRUE or FALSE; defaults to TRUE.}
# \item{plot.chars}{Whether to plot the actual text of the characters.}
# \item{plot.legend}{Whether to plot the legend showing the character-to-color mapping.}
# \item{plot.labels}{Whether to plot the sequence labels along the y-axis}
# \item{aspect.ratio}{(Experimental; when set, this option forces the num.pages value to 1) Constrains the alignment residues to have a certain aspect ratio; values above 1 cause vertically-stretched blocks. FALSE disables aspect ratio control, numerical values set the aspect ratio; defaults to FALSE.}
# \item{num.pages}{Optionally split the alignment over a number of vertically-stacked pages. This is useful for long alignments. 'auto' chooses a sensible number of pages, numerical values specify a number; defaults to 'auto'.}
# \item{char.text.size}{Text size for the aligned characters. This may require tweaking depending on the DPI and output format. Defaults to 'auto'.}
# \item{axis.text.size}{Text size for the sequence labels along the y-axis. This may require tweaking depending on the DPI and output format. Defaults to 'auto'.}
# \item{color.scheme}{Color scheme to use ("auto", "binary", "dna", "protein", "codon", "combined", "combined_codon"). Defaults to 'auto'. When set to 'auto', the function will choose an appropriate coloring scheme based on the alignment content.}
# \item{color.branches}{The event count used to color the branches ("substitutions" by default). See \code{\link{getBranchEvents.PhyloSim}}.}
# \item{tree.xlim}{The x-axis limits of the tree panel.}
# \item{aln.xlim}{The x-axis limits of the alignment panel (in alignment column coordinates).}
# \item{tracks}{Tracks to display above or below the alignment as colored blocks.
#
# The input format for tracks is a list of data frames with the following possible fields, all of which are optional and can be omitted:
# \itemize{
# \item pos - the sequence position (starting with 1) of the feature. Defaults to NULL.
# \item score - the score (between 0 and 1) of the feature. Scores above 1 or below zero will be truncated.
# Defaults to 1.
# \item y_lo - the lower Y offset (between 0 and 1) of the feature. Defaults to 0. Use a y_lo and y_hi
# value for each row in the track data frame to create a wiggle plot like effect.
# \item y_hi - the upper Y offset (between 0 and 1) of the feature. Defaults to 1. Use just a y_hi value
# for each row in the track data frame to create a bar plot like effect.
# \item {the fields below are considered unique per track; the values from the first row in the track
# data frame are used.}
# \item id - the display ID for the track. Defaults to 'Track'.
# \item layout - set to 'above' to put the track above the alignment, 'below' for below.
# \item height - the number of alignment rows for the track to span in height. Defaults to 3.
# \item color.gradient - a comma-separated list of colors to interpolate between when coloring
# the blocks. Examples: 'white,red' 'blue,gray,red' '#FF00FF,#FFFFFF'. Defaults to 'white,black'.
# \item color - a single color to use when coloring the blocks. Mutually exclusive with color.gradient,
# and if a color.gradient value exists then this value will be ignored. Defaults to black.
# \item background - a color for the background of the track. Defaults to white.
# }}
# \item{aln.length.tolerance}{The desired alignment/sequence length ratio (A/S ratio) to trim the alignment to.
# The A/S ratio is defined as the ratio between the alignment length and the mean ungapped sequence length, and
# the alignment trimming procedure will remove blocks of indel-containing columns (in a sensible order) until
# either (a) the desired indel tolerance is reached, or (b) no more columns can be removed without yielding an empty
# alignment. A track is added below the alignment to indicate how many indels each resulting alignment column used
# used to harbor, and black squares are overlaid onto the alignment where extant sequence data has been trimmed.
# Defaults to NULL (no trimming); values in the range of 0.9 to 1.3 tend to work well at improving the
# legibility of very gappy alignments.}
# \item{plot.nongap.bl}{If set to TRUE, plots the non-gap branch length (defined as the branch length of the subtree of non-gapped sequences) as a track below the alignment. Defaults to FALSE.}
# \item{...}{Not used.}
# }
#
# \value{
# The PhyloSim object (invisible).
# }
#
# \examples{
# # Create a PhyloSim object.
# # Provide the phylo object
# # and the root sequence.
# sim<-PhyloSim(
# name="TinySim",
# phylo=rcoal(3),
# root.seq=NucleotideSequence(string="ATGCTAGCTAGG",processes=list(list(JC69())))
# );
# # plot the aggregated phylo object
# plot(sim)
# # run simulation
# Simulate(sim)
# # Plot the alignment without the tree or ancestral sequences.
# plot(sim, plot.ancestors=FALSE, plot.tree=FALSE)
# # Force a DNA-based color scheme
# # (default is 'auto' to auto-detect based on the sequence composition)
# plot(sim, color.scheme='dna', plot.legend=TRUE)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"plot",
class="PhyloSim",
function(
x,
plot.tree,
plot.ancestors,
plot.chars,
plot.legend,
plot.labels,
aspect.ratio,
num.pages,
char.text.size,
axis.text.size,
color.scheme,
color.branches,
tree.xlim,
aln.xlim,
tracks,
aln.length.tolerance,
plot.nongap.bl,
...
){
if(missing(char.text.size)){
char.text.size <- 'auto'
}
if(missing(axis.text.size)){
axis.text.size <- 'auto'
}
if(missing(color.scheme)){
color.scheme <- 'auto'
}
if(missing(color.branches)){
color.branches <- 'substitutions'
}
if(missing(plot.tree)){
plot.tree <- TRUE
}
if(missing(plot.ancestors)){
plot.ancestors <- TRUE
}
if(missing(plot.chars)){
plot.chars <- TRUE
}
if(missing(plot.legend)){
plot.legend <- FALSE
}
if(missing(plot.labels)){
plot.labels <- TRUE
}
if(missing(aspect.ratio)){
aspect.ratio <- FALSE
}
if(missing(num.pages)){
num.pages='auto'
}
if(missing(color.scheme)){
color.scheme='auto'
}
if(missing(tree.xlim)){
tree.xlim=NULL
}
if(missing(aln.xlim)){
aln.xlim=NULL
}
if(missing(tracks)){
tracks=NULL
}
if(any(is.na(x$.phylo))) {
plot.tree <- FALSE
}
if(missing(aln.length.tolerance)){
aln.length.tolerance=NULL
}
if(missing(plot.nongap.bl)){
plot.nongap.bl=FALSE
}
if(all(!is.na(x$.alignment), is.matrix(x$.alignment))){
.plotWithAlignment(x,
plot.tree=plot.tree,
plot.ancestors=plot.ancestors,
plot.chars=plot.chars,
plot.legend=plot.legend,
plot.labels=plot.labels,
aspect.ratio=aspect.ratio,
num.pages=num.pages,
char.text.size=char.text.size,
axis.text.size=axis.text.size,
color.scheme=color.scheme,
color.branches=color.branches,
tree.xlim=tree.xlim,
aln.xlim=aln.xlim,
tracks=tracks,
aln.length.tolerance=aln.length.tolerance,
plot.nongap.bl=plot.nongap.bl
);
return(invisible(x));
}
plot(x$.phylo);
nodelabels();
return(invisible(x));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .plotWithAlignment
##
setMethodS3(
".plotWithAlignment",
class="PhyloSim",
function(
x,
plot.tree,
plot.ancestors,
plot.chars,
plot.legend,
plot.labels,
aspect.ratio,
num.pages,
char.text.size,
axis.text.size,
color.scheme,
color.branches,
tree.xlim,
aln.xlim,
tracks,
aln.length.tolerance,
plot.nongap.bl,
...
){
# ugly empirical fix of some R CMD check warnings:
id <-NA;
pos <-NA;
char <-NA;
xend <-NA;
yend <-NA;
y <-NA;
substitutions<-NA;
event.count <-NA;
type <-NA;
track_index <-NA;
xx <-NA;
yy <-NA;
xmin <-NA;
xmax <-NA;
ymin <-NA;
ymax <-NA;
### First, we need to define a bunch of sparsely-documented utility functions. ###
# Re-orders the alignment rows by matching the tree's tips.
sort.aln.by.tree = function(aln,tree) {
names <- dimnames(aln)[[1]]
if (length(names) > length(tree$tip.label)) {
return(aln)
}
newPositions <- rev(match(tree$tip.label,names))
aln <- aln[newPositions,]
dimnames(aln) <- list(names[newPositions])
return(aln)
}
# Extracts a list of child node IDs for the given node. Returns (-1,-1) if the node is a leaf.
child.nodes <- function(phylo,node) {
edge.indices <- which(phylo$edge[,1]==node)
nodes <- phylo$edge[edge.indices,2]
if (length(nodes)==0) {
nodes <- list(c(-1,-1))
} else {
nodes <- list(nodes)
}
return(list(nodes))
}
# Extracts the parent node ID for the given node. Returns -1 if the node is root.
parent.node <- function(phylo,node) {
edge.index <- which(phylo$edge[,2]==node)
node <- phylo$edge[edge.index,1]
if (length(node)==0) {
node <- -1
}
return(node)
}
generic.count <- function(sim,node,type) {
if (type == 'insertions' || type == 'ins') {
type <- 'insertion'
}
if (type == 'deletions' || type == 'del') {
type <- 'deletion'
}
if (type == 'substitutions' || type == 'subst' || type == 'sub') {
type <- 'substitution'
}
if (type == 'syn') {
type <- 'synonymous'
}
if (type == 'nsyn') {
type <- 'non-synonymous'
}
# Default value of 0.
cnt <- 0
if(type=='none' || type == '') {
return(as.numeric(cnt))
}
# Find the edge which points to the given node.
edge.index <- which(phylo$edge[,2]==node)
if (length(edge.index) > 0) {
bs <- sim$.branch.stats
cnt <- bs[[paste(edge.index)]][[type]]
if (is.null(cnt) || is.na(cnt)) {
cnt <- 0
}
}
return(as.numeric(cnt))
}
subst.count <- function(sim,node) {
return(generic.count(sim,node,'substitution'))
}
ins.count <- function(sim,node) {
return(generic.count(sim,node,'insertion'))
}
del.count <- function(sim,node) {
return(generic.count(sim,node,'deletion'))
}
syn.count <- function(sim,node) {
return(generic.count(sim,node,'synonymous'))
}
nsyn.count <- function(sim,node) {
return(generic.count(sim,node,'non-synonymous'))
}
# Finds the node with a given label.
node.with.label <- function(tree,label) {
return(which(tree$tip.label %in% label))
}
# Extracts the length of the branch above the given node. Returns 0 if the node is root.
branch.length <- function(phylo,node) {
edge.index <- which(phylo$edge[,2]==node)
bl <- phylo$edge.length[edge.index]
if (length(bl)==0) {
bl <- 0
}
return(bl)
}
# The maximum root-to-tip length in the tree.
max.length.to.root <- function(phylo) {
max.length <- 0
for (i in 1:length(phylo$tip.label)) {
cur.length <- length.to.root(phylo,i)
max.length <- max(max.length,cur.length)
}
return(max.length)
}
# The length from the root to the given node. Can be given either as a node ID or a tip label.
length.to.root <- function(phylo,node) {
tip.index <- node
if (is.character(node)) {
tip.index <- which(phylo$tip.label==node)
}
cur.node.b <- tip.index
p.edges <- phylo$edge
p.lengths <- phylo$edge.length
length <- 0
while(length(which(p.edges[,2]==cur.node.b)) > 0) {
cur.edge.index <- which(p.edges[,2]==cur.node.b)
cur.edge.length <- p.lengths[cur.edge.index]
length <- length + cur.edge.length
cur.node.a <- p.edges[cur.edge.index,1]
cur.node.b <- cur.node.a # Move up to the next edge
}
return(length)
}
# Returns a data frame defining segments to draw the phylogenetic tree.
phylo.layout.df <- function(phylo,layout.ancestors=FALSE,align.seq.names=NULL) {
# Number of nodes and leaves.
n.nodes <- length(phylo$tip.label)+phylo$Nnode
n.leaves <- length(phylo$tip.label)
# Create the skeleton data frame.
df <- data.frame(
node=c(1:n.nodes), # Nodes with IDs 1 to N.
x=0, # These will contain the x and y coordinates after the layout procedure below.
y=0,
label=c(phylo$tip.label,((n.leaves+1):n.nodes)), # The first n.leaves nodes are the labeled tips.
is.leaf=c(rep(TRUE,n.leaves),rep(FALSE,n.nodes-n.leaves)), # Just for convenience, store a boolean whether it's a leaf or not.
parent=0, # Will contain the ID of the current node's parent
children=0, # Will contain a list of IDs of the current node's children
branch.length=0 # Will contain the branch lengths
)
# Collect the parents, children, and branch lengths for each node
parent <- c()
bl <- list()
children <- list()
event.count <- list()
for (i in 1:nrow(df)) {
node <- df[i,]$node
parent <- c(parent,parent.node(phylo,node))
bl <- c(bl,branch.length(phylo,node))
children <- c(children,child.nodes(phylo,node))
event.count <- c(event.count,generic.count(x,node,color.branches))
}
df$parent <- parent
df$children <- children
df$branch.length <- bl
df$event.count <- as.numeric(event.count)
# Start the layout procedure by equally spacing the leaves in the y-dimension.
df[df$is.leaf==TRUE,]$y = c(1:n.leaves)
found.any.internal.node.sequences <- FALSE
# For each leaf: travel up towards the root, laying out each internal node along the way.
for (i in 1:n.leaves) {
cur.node <- i
while (length(cur.node) > 0 && cur.node != -1) {
# We always use branch lengths: x-position is simply the length to the root.
df[cur.node,]$x <- length.to.root(phylo,cur.node)
# The y-position for internal nodes is the mean of the y-position of the two children.
children <- unlist(df[cur.node,]$children)
if (length(children) > 0 && children[1] != -1) {
child.a <- children[1]
child.b <- children[2]
child.a.y <- df[child.a,]$y
child.b.y <- df[child.b,]$y
df[cur.node,]$y <- (child.a.y+child.b.y)/2
}
# Try to find the index of this node in the alignment names.
if (!is.null(align.seq.names)) {
lbl <- df[cur.node,]$label
index.in.names <- which(align.seq.names == lbl | align.seq.names %in% c(paste('Node',lbl),paste('Root node',lbl)))
if (length(index.in.names)>0) {
df[cur.node,]$y <- index.in.names
if (!df[cur.node,]$is.leaf) {
found.any.internal.node.sequences <- TRUE
}
}
}
cur.node <- unlist(df[cur.node,]$parent)
}
}
# We have a data frame with each node positioned.
# Now we go through and make two line segments for each node (for a 'square corner' type tree plot).
line.df <- data.frame()
for (i in 1:nrow(df)) {
row <- df[i,] # Data frame row for the current node.
if (row$parent == -1) {
next; # Root node!
}
p.row <- df[row$parent,] # Data frame row for the parent node.
if (layout.ancestors && found.any.internal.node.sequences) {
horiz.line <- data.frame(
x=row$x,
xend=p.row$x,
y=row$y,
yend=p.row$y,
lbl=row$label,
event.count=row$event.count
)
line.df <- rbind(line.df,horiz.line)
} else {
horiz.line <- data.frame(
x=row$x,
xend=p.row$x,
y=row$y,
yend=row$y,
lbl=row$label,
event.count=row$event.count
) # First a line from row.x to parent.
vert.line <- data.frame(
x=p.row$x,
xend=p.row$x,
y=row$y,
yend=p.row$y,
lbl=row$label,
event.count=row$event.count
) # Now a line from row.y to parent.y
#horiz.line <- data.frame(x=row$x,xend=(p.row$x+row$x)/2,y=row$y,yend=row$y,lbl=row$label) # First a line from row.x to parent.
#vert.line <- data.frame(x=(p.row$x+row$x)/2,xend=p.row$x,y=row$y,yend=p.row$y,lbl=row$label) # Now a line from row.y to parent.y
line.df <- rbind(line.df,horiz.line,vert.line)
}
}
return(line.df)
}
# Call this to put a ggplot panel into a specified layout position [for example: print(p,vp=subplot(1,2)) ]
subplot <- function(x, y) viewport(layout.pos.col=x, layout.pos.row=y)
# Call this to create a layout with x and y rows and columns, respectively
vplayout <- function(x, y) {
grid.newpage()
pushViewport(viewport(layout=grid.layout(y,x)))
}
# Creates a color aesthetic for alignments
alignment.colors <- function(scheme,darken=F) {
scheme <- tolower(scheme)
if (scheme == 'binary') {
cols <- c(
'0' = "#000000",
'1' = '#FFFFFF'
)
} else if (scheme == 'dna') {
cols <- c(
'G' = "#FFFF00",
'C' = "#00FF00",
'T' = "#FF0000",
'A' = "#0000FF"
)
} else if (scheme == 'numeric') {
#cols <- heat.colors(10)
cols <- colorRampPalette(c("red","yellow","green"))(10)
cols <- c(
'0' = cols[1],
'1' = cols[2],
'2' = cols[3],
'3' = cols[4],
'4' = cols[5],
'5' = cols[6],
'6' = cols[7],
'7' = cols[8],
'8' = cols[9],
'9' = cols[10]
)
} else if (scheme == 'taylor' || scheme == 'protein') {
cols <- c(
'A' = "#CCFF00", 'a' = "#CCFF00",
'C' = "#FFFF00", 'c' = "#FFFF00",
'D' = "#FF0000", 'd' = "#FF0000",
'E' = "#FF0066", 'e' = "#FF0066",
'F' = "#00FF66", 'f' = "#00FF66",
'G' = "#FF9900", 'g' = "#FF9900",
'H' = "#0066FF", 'h' = "#0066FF",
'I' = "#66FF00", 'i' = "#66FF00",
'K' = "#6600FF", 'k' = "#6600FF",
'L' = "#33FF00", 'l' = "#33FF00",
'M' = "#00FF00", 'm' = "#00FF00",
'N' = "#CC00FF", 'n' = "#CC00FF",
'P' = "#FFCC00", 'p' = "#FFCC00",
'Q' = "#FF00CC", 'q' = "#FF00CC",
'R' = "#0000FF", 'r' = "#0000FF",
'S' = "#FF3300", 's' = "#FF3300",
'T' = "#FF6600", 't' = "#FF6600",
'V' = "#99FF00", 'v' = "#99FF00",
'W' = "#00CCFF", 'w' = "#00CCFF",
'Y' = "#00FFCC", 'y' = "#00FFCC",
'2' = "#888888", '2' = "#888888",
'O' = "#424242", 'o' = "#424242",
'B' = "#7D7D7D", 'b' = "#7D7D7D",
'Z' = "#EEEEEE", 'z' = "#EEEEEE",
'X' = "#000000", 'x' = "#000000"
)
} else if (scheme == 'codon') {
# Get the protein colors.
protein.colors <- alignment.colors('protein')
# Create a list of codons.
ca <- CodonAlphabet()
nucs <- c('G','A','C','T')
codons <- expand.grid(nucs,nucs,nucs,stringsAsFactors=F)
# For each codon give the protein color.
codon.colors <- c()
for (i in 1:nrow(codons)) {
codon = paste(codons[i,],collapse='')
aa <- translateCodon(ca,codon)
codon.colors[codon] = protein.colors[aa]
}
cols <- codon.colors
} else if (scheme == 'combined') {
dna.colors <- alignment.colors('dna')
binary.colors <- alignment.colors('binary')
protein.colors <- alignment.colors('protein')
cols <- c(dna.colors,protein.colors,binary.colors)
} else if (scheme == 'combined_codon') {
dna.colors <- alignment.colors('dna')
# Make the DNA stand out here by being a little darker
for (i in 1:length(dna.colors)) {
color <- dna.colors[i]
darker.color <- darker(color)
dna.colors[i] <- darker.color
}
binary.colors <- alignment.colors('binary')
protein.colors <- alignment.colors('protein')
codon.colors <- alignment.colors('codon')
# Put them all together. (One remaining issue: the protein G,A,T,C will be colored as DNA!)
cols <- c(dna.colors,protein.colors,binary.colors,codon.colors)
}
if (darken) {
for (i in 1:length(cols)) {
color <- cols[i]
darker.color <- darker(color,0.85)
cols[i] <- darker.color
}
}
return(cols)
}
darker <- function(color,factor=0.7) {
x <- col2rgb(color)
x <- round(x * factor)
y <- rgb(x[1],x[2],x[3],maxColorValue=255)
return(y)
}
lighter <- function(color) {
x <- col2rgb(color)
x <- round(x * 1.2)
y <- rgb(min(x[1],255),min(x[2],255),min(x[3],255),maxColorValue=255)
return(y)
}
# Scores each column according to the branch length of the subtree created by
# non-gap residues (we use nongap.bl as the var name), and stores the 'nongap.str'
# which is the pasted list of labels for non-gapped sequences at this site.
# This information is used by the 'remove.gaps' function to remove columns to
# reach a certain alignment length threshold.
score.aln.columns <- function(tree,aln) {
aln.length <- length(aln[1,])
score.df <- data.frame()
for (i in 1:aln.length) {
aln.column <- aln[,i]
nongap.seqs <- names(aln.column[aln.column != '-'])
gap.seqs <- names(aln.column[aln.column == '-'])
# Get the non-gap branch length.
if (length(nongap.seqs) == 1) {
nongap.node <- node.with.label(tree,nongap.seqs[1])
nongap.bl <- branch.length(tree,nongap.node)
} else {
nongap.tree <- drop.tip(tree,gap.seqs)
nongap.bl <- sum(nongap.tree$edge.length)
}
nongap.str <- paste(nongap.seqs,collapse=';')
cur.df <- data.frame(
pos=i,
score=nongap.bl,
nongap.str=nongap.str,
stringsAsFactors=F
)
score.df <- rbind(score.df,cur.df)
}
score.df <- score.df[order(score.df$score,score.df$pos),]
return(score.df)
}
# Goes through the alignment of the sim object and removes columns until either the desired
# tolerance is reached or there are no more low-scoring columns to remove (whichever comes
# first). Tolerance is defined as the ratio of the alignment length to the mean sequence
# length. So, an alignment with no indels at all is exactly 1; an alignment with lots
# of deletions (but no insertion) is less than 1; an alignment with lots of insertion is
# greater than 1.
#
# Values of 0.9 - 1.3 tend to give good results in a variety of situations.
#
remove.gaps <- function(sim,tolerance) {
aln <- sim$.alignment
tree <- sim$.phylo
col.scores <- score.aln.columns(tree,aln)
# Store the deletion markers in a separate data frame.
deletion.df <- NULL
# Get the mean sequence length
lengths <- apply(aln,1,function(x) {
x <- x[x != '-']
return(stringLength(paste(x,collapse='')))
})
mean.seq.length <- mean(lengths)
repeat {
aln.length <- length(aln[1,])
ratio <- aln.length / mean.seq.length
if (ratio < tolerance) {
break;
}
# Take the next site from the sorted scores
lowest.scores <- col.scores[1,]
col.scores <- col.scores[-c(1),]
cur.pos <- lowest.scores$pos # Current position of lowest-scoring column.
cur.score <- lowest.scores$score # The current column score.
cur.str <- lowest.scores$nongap.str # The current column's nongap pattern.
# Grab the entire 'current chunk' of alignment which has the same
# score and non-gap string.
repeat {
first.pos <- col.scores[1,'pos']
first.score <- col.scores[1,'score']
first.str <- col.scores[1,'nongap.str']
if (cur.score == max(col.scores$score)) {
lowest.scores <- NULL
cur.ratio <- length(aln[1,]) / mean.seq.length
print(sprintf("Nothing left to remove at ratio %.2f!",cur.ratio))
break;
}
if (first.pos == cur.pos + 1 && first.score == cur.score && first.str == cur.str) {
cur.pos <- col.scores[1,]$pos
lowest.scores <- rbind(lowest.scores,col.scores[1,])
col.scores <- col.scores[-1,]
} else {
#print("Done!")
break;
}
}
if (is.null(lowest.scores)) {
break;
}
# remove.us should be a contiguous vector of integers,
# representing the set of columns to remove.
remove.us <- lowest.scores$pos
if (any(diff(remove.us) > 1)) {
print("ERROR: Removing a non-consecutive set of columns!")
}
#print(paste("Removing at ",paste(remove.us[1])))
# Go through columns from right to left, making sure to update
# the new positions of columns on the right side of the splice.
rev.pos <- rev(remove.us)
for (i in 1:length(rev.pos)) {
cur.pos <- rev.pos[i]
aln <- splice.column(aln, cur.pos)
# Update new positions of column scores
above <- which(col.scores$pos > cur.pos)
col.scores[above,]$pos <- col.scores[above,]$pos - 1
# Update new positions of deletion locations.
if (!is.null(deletion.df) && nrow(deletion.df) > 0) {
above <- which(deletion.df$pos > cur.pos)
deletion.df[above,]$pos <- deletion.df[above,]$pos - 1
}
}
# Add a single entry to the data frame of deletions, to be used
# by the plot function to indicate deletion points.
cur.deletion <- data.frame(
pos = cur.pos, # The first position AFTER the deletion splice.
length = length(rev.pos), # The length of the block removed.
nongap.str = as.character(cur.str), # nongap sequence IDs for this deletion
stringsAsFactors=F
)
#print(cur.deletion)
deletion.df <- rbind(deletion.df,cur.deletion)
}
# Create a new PhyloSim object, assign the tree & aln, and return.
sim.temp <- PhyloSim();
sim.temp$.alignment <- aln
sim.temp$.phylo <- tree
sim.temp$.indels <- deletion.df
return(sim.temp)
}
splice.column <- function(aln,pos) {
return(aln[,-pos])
}
####################################
### Let the real plotting begin! ###
####################################
# Apply the deletion tolerance if needed.
if (!is.null(aln.length.tolerance)) {
x <- remove.gaps(x, tolerance=aln.length.tolerance)
indels <- x$.indels
} else {
indels <- NULL
}
df <- data.frame()
aln <- x$.alignment
phylo <- x$.phylo
# Do some reordering of alignment & tree.
if (!any(is.na(phylo))) {
x$.phylo <- reorder(x$.phylo, order="cladewise");
phylo <- x$.phylo
aln <- sort.aln.by.tree(aln,phylo)
}
names <- dimnames(aln)[[1]]
#print(paste("Aln length:",length(aln[1,])))
#print(paste("Num seqs:",length(names)))
# Create a factor of all the characters in the alignment.
char.levels <- sort(unique(as.vector(aln)))
names.levels <- names
for (i in 1:length(names)) {
char.list <- aln[i,]
name <- names[i]
# Store the indices of where the gaps are -- we won't plot the gaps.
gaps <- char.list == '-'
seq.pos <- seq(1,length(char.list))
# Get the position and character of each non-gap residue.
pos.nogaps <- seq.pos[gaps==FALSE]
char.nogaps <- as.character(char.list[gaps==FALSE])
# Create a data frame with 1 row per residue to plot.
df <- rbind(df,data.frame(
id=factor(x=rep(name,length(pos.nogaps)),levels=names.levels), # Sequence ID to which this residue belongs
seq_index=rep(i,length(pos.nogaps)), # Index of the containing sequence
pos=pos.nogaps, # Alignment position
char=factor(x=char.nogaps,levels=char.levels) # Character of the residue
))
}
# Turn the IDs into a factor to plot along the y axis.
if (!plot.ancestors) {
# Remove the ancestral nodes from the plot.
tip.name.indices <- grep("node",names,ignore.case=TRUE,invert=TRUE)
names <- names[tip.name.indices]
df$id <- factor(df$id,levels=names)
df <- subset(df,id %in% names)
}
df$type <- 'aln'
### Add indels to the data frame.
if (!is.null(indels)) {
# For each non-gap sequence of each chunk deleted, add a row
# to the data frame.
del.df <- data.frame()
# For each position, store the count of indels in a track.
max.pos <- max(c(df$pos,indels$pos))
indel.histogram <- data.frame(
pos=1:max.pos - 0.5,
count=0,
length=0
)
for (i in 1:nrow(indels)) {
row <- indels[i,]
seqs <- strsplit(row$nongap.str,";")[[1]]
if (length(seqs) == 0) {
# Edge case: an indel row came from a column with no aligned sequence,
# so the 'nongap.str' is empty. Just continue on...
next()
}
cur.df <- data.frame(
id=seqs,
pos=row$pos,
length=row$length,
type='indel'
)
del.df <- rbind(del.df,cur.df)
# Tick up the histogram.
indel.histogram[row$pos,]$count <- indel.histogram[row$pos,]$count + 1
indel.histogram[row$pos,]$length <- indel.histogram[row$pos,]$length + row$length
}
# Sync the two data frame's columns, fill empty stuff with NAs.
columns.from.df <- colnames(df)[!(colnames(df) %in% colnames(del.df))]
columns.from.del <- colnames(del.df)[!(colnames(del.df) %in% colnames(df))]
del.df[,columns.from.df] <- NA
df[,columns.from.del] <- NA
df <- rbind(df,del.df)
# Transform the histogram and add it to our tracks.
max.count <- max(indel.histogram$count)
max.length <- max(indel.histogram$length)
indel.histogram$y_lo <- 0
indel.histogram$score <- indel.histogram$count / (max.count+1)
indel.histogram$y_hi <- indel.histogram$score
indel.histogram$id <- 'Hidden Indel Count'
indel.histogram$height <- 5
indel.histogram$layout <- 'below'
indel.histogram$color.gradient <- 'darkblue,darkblue'
indel.histogram$type <- 'track'
#indel.len <- indel.histogram
#indel.len$id <- 'Hidden Indel Length'
#indel.len$score <- indel.len$length / (max.length+1)
#indel.len$y_hi <- indel.len$score
#indel.len$color.gradient <- 'darkgreen,darkgreen'
if (!is.null(tracks)) {
tracks <- c(tracks,list(indel.histogram))
} else {
tracks <- list(indel.histogram)
}
}
if (plot.nongap.bl && is.phylo(phylo)) {
score.df <- score.aln.columns(phylo,aln)
max.bl <- max(score.df$score)
bl.track <- data.frame(
id = 'Non-gap Branch Length',
layout = 'below',
pos = score.df$pos,
score = score.df$score / max.bl * 0.9,
y_hi = score.df$score / max.bl * 0.9,
color.gradient = 'red,black,black'
)
if (!is.null(tracks)) {
tracks <- c(tracks,list(bl.track))
} else {
tracks <- list(bl.track)
}
}
# Track input format is a list of data frames with one row per feature to be
# displayed, with the following columns. The only mandatory column is 'pos';
# all others have sensible default values.
# ---
# [fields below are unique per row]
# pos: The sequence position (starting with 1) of the feature
# score: The score (between 0 and 1) of the feature. Scores above 1 or below
# zero will be truncated.
# y_lo: The lower Y offset (between 0 and 1) of the feature block.
# y_hi: The upper Y offset (between 0 and 1) of the feature block. These two
# values allow bars to be positioned along the y-axis.
# [fields below are unique per track; the value from the first row is used.]
# id: The display ID for the track.
# layout: Set to 'above' to put the track above the alignment, 'below' for below.
# height: The number of alignment rows for the track to span in height.
# color.gradient: A comma-separated list of colors to interpolate between when coloring
# the blocks. Examples: 'white,red' 'blue,gray,red' '#FF00FF,#FFFFFF'
# color: A single color to use for the track, no matter what the scores. Overridden
# color.gradient if both exist.
#
# ---
#
# What we do is add the track data to the alignment data frame (so it gets
# paged and scaled properly along with the alignment data) and then separate
# it out before plotting, so it can be plotted separately from the alignment.
df$track_index <- -1
if (!is.null(tracks)) {
df$score <- NA
i <- 0
for (track in tracks) {
i <- i + 1
track$track_index <- i
track$type <- 'track'
# Add default values.
if (is.null(track$background)) {
track$background <- 'white'
}
if (length(track$pos) == 0) {
# If no positions are included in the data frame, set the first position
# to 1 and put the foreground color same as the background.
# This has the effect of creating a 'spacer' row.
track$pos <- 1
track$color <- track[1,]$background
}
if (is.null(track$layout)) {
track$layout <- 'above'
}
if (is.null(track$color.gradient)) {
if (!is.null(track$color)) {
# No color gradient exists, but we have 'color' instead. Use that.
track$color.gradient <- paste(track[1,]$color, track[1,]$color, sep=',')
} else {
# No color.gradient OR color value exists, so use the default white-to-black.
track$color.gradient <- 'white,black'
}
}
if (is.null(track$score)) {
track$score <- 1
}
if (is.null(track$y_lo)) {
track$y_lo = 0
}
if (is.null(track$y_hi)) {
track$y_hi = 1
}
if (is.null(track$id)) {
track$id <- paste('Track',i)
}
if (is.null(track$height) || is.na(track$height)) {
track$height <- 4
}
# Ensure that we don't have positions at zero or below.
track[track$pos <= 0,'pos'] <- 1
# Limit score range
track$score <- pmin(track$score,1)
track$score <- pmax(track$score,0)
# Sync the two data frame's columns, fill empty stuff with NAs.
columns.from.aln <- colnames(df)[!(colnames(df) %in% colnames(track))]
columns.from.track <- colnames(track)[!(colnames(track) %in% colnames(df))]
track[,columns.from.aln] <- NA
df[,columns.from.track] <- NA
track$type <- 'track'
df <- rbind(df,track)
}
}
if (num.pages != 'auto') {
num.pages <- as.numeric(num.pages)
}
aln.length <- max(df$pos)
chars.per.page <- aln.length
num.seqs <- length(names)
if (tolower(num.pages) == 'auto' || num.pages > 1) {
# Plotting a multi-page alignment.
if (tolower(num.pages) == 'auto') {
# If we have tracks, add the total track height to the 'num.seqs' variable.
track.rows <- subset(df,type == 'track')
if (nrow(track.rows) > 0) {
track.indices <- sort(unique(track.rows$track_index))
for (track.index in track.indices) {
sub.track <- subset(track.rows,track_index==track.index)
if (nrow(sub.track) > 0) {
num.seqs <- num.seqs + sub.track[1,]$height
}
}
}
# Formula to get a square-ish total plot.
num.pages <- sqrt(aln.length/num.seqs)
num.pages <- ceiling(num.pages)+1
# One-page rule for short alignments.
if (aln.length < 30) {num.pages <- 1}
}
# Add a 'page' factor to the data frame and use facet_grid.
chars.per.page <- ceiling(aln.length / num.pages)
df$page <- floor((df$pos-1) / chars.per.page) + 1
if (nrow(subset(df,page <= 0)) > 0) {
df[df$page <= 0,]$page <- 1 # Fix errors where pos=0.5 goes to page 0
}
df$pos <- df$pos - (chars.per.page*(df$page-1))
page.labels <- paste((0:(num.pages-1))*chars.per.page+1,(1:num.pages)*chars.per.page,sep="-")
page.numbers <- sort(unique(df$page))
page.labels <- page.labels[page.numbers]
df$page <- factor(df$page,levels=page.numbers,labels=page.labels)
num.pages <- length(page.labels)
#print(paste("Num pages:",num.pages))
} else {
# We've only got one page. Create a factor...
df$page <- 1
df$page <- factor(df$page,levels=c(1),labels=c('1'))
# Store some values which will be used later.
aln.length <- max(df$pos)
chars.per.page <- aln.length
}
if (color.scheme == 'auto') {
all.chars <- unlist(aln)
all.chars <- all.chars[all.chars != '-']
n.chars <- length(unique(toupper(all.chars)))
dna <- c('a','t','g','c')
dna <- c(dna,toupper(dna))
protein <- letters
protein <- protein[!(protein %in% c('b','j','o','u','x','z'))]
protein <- c(protein,toupper(protein))
ca <- CodonAlphabet()
nucs <- c('G','A','C','T')
codon.grid <- expand.grid(nucs,nucs,nucs,stringsAsFactors=F)
codons <- c()
for (i in 1:nrow(codon.grid)) {
codons <- c(codons,paste(codon.grid[i,],collapse=''))
}
if(any(all.chars %in% codons)) {
# If we see any codon alphabets, use the combined_codon
color.scheme <- 'combined_codon'
} else {
# Else just use the combined color scheme. It's good enough!
color.scheme <- 'combined'
}
}
legend.title <- color.scheme
# Remove any tracks from the main aln data frame.
tracks <- subset(df,type=='track')
indels <- subset(df,type=='indel')
df <- subset(df,type=='aln')
# Set positional values in the aln data frame.
df$xx <- df$pos
df$yy <- as.numeric(df$id)
df$xmin <- df$xx - .5
df$xmax <- df$xx + .5
df$ymin <- df$yy - .5
df$ymax <- df$yy + .5
darken.colors <- FALSE
if (nrow(indels) > 0) {
darken.colors <- TRUE
}
color.map <- alignment.colors(color.scheme,darken=darken.colors)
df$colors <- color.map[as.character(df$char)]
# Set the base for y-axis configurations.
y.lim <- c(0,length(names)+1)
y.breaks <- 1:length(names)
y.labels <- names
# Create the ggplot panel.
p <- ggplot(df,aes(x=xx,y=yy,xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax))
p <- p + geom_rect(aes(fill=colors))
if (!is.null(aln.xlim)) {
aln.limits <- aln.xlim
} else {
aln.limits <- c(0,max(df$pos)+1)
}
if (nrow(tracks) > 0) {
# Handle tracks.
# These variables hold the current above and below offsets.
cur.y.above <- length(names) + 1 - .5
y.lim[2] <- length(names) + 1 - .5
cur.y.below <- 0.5
bg.out <- data.frame()
track.out <- data.frame()
track.indices <- sort(unique(tracks$track_index))
for (track.index in track.indices) {
sub.track <- subset(tracks,track_index==track.index)
# Collect the track-wide features.
track.id <- sub.track[1,]$id
track.height <- sub.track[1,]$height
track.layout <- sub.track[1,]$layout
color.gradient <- strsplit(sub.track[1,]$color.gradient,',')[[1]]
track.bg <- sub.track[1,]$background
track.ramp <- colorRamp(colors=color.gradient)
sub.track$colors <- rgb(track.ramp(sub.track$score),maxColorValue=255)
sub.track$xx <- sub.track$pos
sub.track$xmin <- sub.track$pos-.5
sub.track$xmax <- sub.track$pos+.5
if (track.layout == 'below') {
sub.track$yy <- cur.y.below
sub.track$ymin <- cur.y.below - track.height
sub.track$ymax <- cur.y.below
y.lim[1] <- cur.y.below - track.height
y.breaks <- c(y.lim[1] + track.height/2,y.breaks)
y.labels <- c(as.character(track.id),y.labels)
# Temporarily store the current min and max for y.
cur.y.min <- cur.y.below - track.height
cur.y.max <- cur.y.below
# Add our track height to the state variable.
cur.y.below <- cur.y.below - track.height
} else {
sub.track$yy <- cur.y.above
sub.track$ymin <- cur.y.above
sub.track$ymax <- cur.y.above + track.height
y.lim[2] <- cur.y.above + track.height
y.breaks <- c(y.breaks,y.lim[2] - track.height/2)
y.labels <- c(y.labels,as.character(track.id))
# Temporarily store the current min and max for y.
cur.y.min <- cur.y.above
cur.y.max <- cur.y.above + track.height
# Add our track height to the state variable.
cur.y.above <- cur.y.above + track.height
}
# Adjust bar position if we have y_lo and y_hi values.
if(length(sub.track$y_lo) > 0) {
sub.track$ymin <- cur.y.min + track.height*sub.track$y_lo
}
if (length(sub.track$y_hi) > 0) {
sub.track$ymax <- cur.y.min + track.height*sub.track$y_hi
}
track.out <- rbind(track.out,sub.track)
# Create a background rectangle for each page, to place behind the current track.
pages <- sort(unique(df$page))
page.indices <- sort(unique(as.integer(df$page)))
for (page.index in 1:length(pages)) {
pg <- pages[page.index]
current.track.bg <- data.frame(
page=pg,
colors=track.bg,
xx=0.5,
yy=cur.y.min,
xmin=0.5,
xmax=chars.per.page + 0.5,
ymin=cur.y.min,
ymax=cur.y.max
)
bg.out <- rbind(bg.out,current.track.bg)
}
}
# Add layers for the backgrounds and tracks.
p <- p + geom_rect(aes(fill=colors),data=bg.out)
p <- p + geom_rect(aes(fill=colors),data=track.out)
}
if (nrow(indels) > 0) {
# Plot indels as small bars on top of characters.
indel.width <- 0.25
indels$pos <- indels$pos - .5 # Position indel on seq boundary.
indels$xx <- indels$pos
indels$yy <- as.numeric(indels$id)
indels$xmin <- indels$xx - indel.width
indels$xmax <- indels$xx + indel.width
indels$ymin <- indels$yy - .5
indels$ymax <- indels$yy + .5
indels$colors <- 'black'
p <- p + geom_rect(aes(fill=colors),data=indels)
}
#color.map <- alignment.colors(color.scheme)
p <- p + scale_fill_identity()
p <- p + scale_x_continuous(limits=aln.limits,expand=c(0,0))
if (plot.labels) {
p <- p + scale_y_continuous(limits=y.lim,breaks=y.breaks,labels=y.labels,expand=c(0,0))
} else {
p <- p + scale_y_continuous(limits=y.lim,breaks=y.breaks,labels=rep('',length(y.labels)),expand=c(0,0))
}
if (aspect.ratio) {
axis.text.size <- 5
char.text.size <- 2
}
if (num.pages > 1) {
p <- p + facet_grid(page ~ .)
}
if (char.text.size == 'auto') {
char.text.size <- 125 / (num.pages * (num.seqs+1))
char.text.size <- min(char.text.size,10)
char.text.size <- max(char.text.size,1)
}
if (plot.chars) {
p <- p + geom_text(aes(label=char),colour='black',size=char.text.size)
}
if (aspect.ratio) {
p <- p + coord_equal(ratio=aspect.ratio)
}
if (axis.text.size == 'auto') {
axis.text.size <- 500 / (num.pages * (num.seqs+1))
axis.text.size <- min(axis.text.size,10)
axis.text.size <- max(axis.text.size,1)
}
plot.theme <- theme(
axis.text.y = element_text(size=axis.text.size,hjust=1),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.ticks = element_blank(),
panel.grid.minor = element_blank(),
panel.grid.major = element_blank(),
plot.margin = unit(c(0,0,0,0),'npc')
)
p <- p + plot.theme
if (!plot.legend) {
p <- p + theme(legend.position='none')
}
if (plot.tree) {
if (plot.ancestors) {
tree.df <- phylo.layout.df(phylo,layout.ancestors=TRUE,align.seq.names=names)
} else {
tree.df <- phylo.layout.df(phylo,align.seq.names=names)
}
if (num.pages > 1) {
tree.df$page <- 1
df.copy <- tree.df
for (i in 2 : num.pages) {
df.copy$page <- i
tree.df <- rbind(tree.df,df.copy)
}
}
max.length <- max.length.to.root(phylo)
aln.length <- length(aln[1,])
n.leaves <- length(names)
if (max(tree.df$event.count) > 0) {
#print(paste("Coloring tree by",color.branches))
q <- ggplot(tree.df,aes(colour=event.count))
q <- q + scale_colour_gradient()
} else {
q <- ggplot(tree.df)
}
q <- q + geom_segment(aes(x=x,y=y,xend=xend,yend=yend))
if (plot.labels) {
q <- q + scale_y_continuous(limits=y.lim,breaks=y.breaks,labels=y.labels,expand=c(0,0))
} else {
q <- q + scale_y_continuous(limits=y.lim,breaks=y.breaks,labels=rep('',length(y.labels)),expand=c(0,0))
}
if (!is.null(tree.xlim)) {
tree.limits <- tree.xlim
} else {
tree.limits <- c(0,max.length)
}
q <- q + scale_x_continuous(limits=tree.limits,expand=c(0.05,0))
q <- q + plot.theme
# q <- q + theme(plot.margin = unit(c(0,0,0,0),'npc'))
if (num.pages > 1) {
q <- q + facet_grid(page ~ .)
q <- q + theme(strip.text.y=element_blank())
}
if (!plot.legend) {
q <- q + theme(legend.position='none')
}
if (aspect.ratio) {
warning("Aspect ratio set while plotting tree -- the alignment and tree won't line up!")
}
vplayout(4,1)
print(p,vp=subplot(2:4,1))
print(q,vp=subplot(1,1))
} else {
p <- p + plot.theme
print(p)
}
# this method has no meaningful return value
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.PhyloSim
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
# # Create a PhyloSim object.
# # Provide the phylo object
# # and the root sequence.
# sim<-PhyloSim(
# name="TinySim",
# phylo=rcoal(3),
# root.seq=NucleotideSequence(string="ATG",processes=list(list(JC69())))
# );
# # get a summary
# summary(sim)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="PhyloSim",
function(
object,
...
){
this<-object;
this$.summary$"Name"<-this$name;
this$.summary$"Id"<-this$id;
if(is.Sequence(this$rootSeq)){
root.seq<-this$rootSeq$id;
} else {
this$.summary$"Root Sequence"<-"undefined";
}
if(is.Sequence(this$rootSeq)){
this$.summary$"Root Sequence big rate"<-this$rootSeq$bigRate;
}
if(is.phylo(this$.phylo)){
this$.summary$"Tree length"<-this$treeLength;
phylo.details<-grep(pattern="[[:alnum:]]+",x=capture.output(print(this$.phylo)),perl=TRUE,value=TRUE);
phylo.details<-paste("\n",phylo.details,collapse="",sep="\t");
this$.summary$"Phylo object details"<-phylo.details;
} else {
this$.summary$"Phylo object details"<-"undefined";
}
aln<-"undefined";
if(is.matrix(this$alignment)){
aln<-"defined";
}
this$.summary$"Alignment"<-aln;
this$.summary$"Log file"<-this$.log.file;
this$.summary$"Log level"<-this$.log.level;
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##### Logging Methods #####
##
## Method: getLogFile
##
###########################################################################/**
#
# @RdocMethod getLogFile
#
# @title "Get the name of the file used for logging"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # Create a PhyloSim object
# sim<-PhyloSim();
# # get the name of the log file
# getLogFile(sim)
# # modify log file name
# setLogFile(sim,"OldLog.txt")
# # get/set log file name via virtual field
# sim$logFile
# sim$logFile<-"NewLog"
# sim$logFile
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getLogFile",
class="PhyloSim",
function(
this,
...
){
this$.log.file;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setLogFile
##
###########################################################################/**
#
# @RdocMethod setLogFile
#
# @title "Set the name of the file used for logging"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{value}{The name of the file used for logging.}
# \item{...}{Not used.}
# }
#
# \value{
# The new logfile.
# }
#
# \examples{
# # Create a PhyloSim object
# sim<-PhyloSim();
# # get the name of the log file
# getLogFile(sim)
# # modify log file name
# setLogFile(sim,"OldLog.txt")
# # get/set log file name via virtual field
# sim$logFile
# sim$logFile<-"NewLog"
# sim$logFile
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setLogFile",
class="PhyloSim",
function(
this,
value,
...
){
if(missing(value)){
throw("No value provided!\n");
}
value<-as.character(value);
if( length(value) != 1 ){
throw("The new value must be a character vector of length 1!\n");
}
else{
if( file.access(value,mode=0) == c(0) ){
warning("The specified file already exists and it will be overwritten during simulation!\n");
}
this$.log.file<-value;
}
return(this$.log.file);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getLogLevel
##
###########################################################################/**
#
# @RdocMethod getLogLevel
#
# @title "Get the log level from a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# The log level as an integer vector of length one.
# }
#
# \examples{
# # Create a PhyloSim object
# sim<-PhyloSim();
# # get/set log level
# getLogLevel(sim)
# setLogLevel(sim,0)
# # set/get log level via virtual field
# sim$logLevel<- -1
# sim$logLevel
# # clean up
# unlink(sim$logFile)
# }
#
# @author
#
# \seealso{
# setLogLevel PhyloSim
# }
#
#*/###########################################################################
setMethodS3(
"getLogLevel",
class="PhyloSim",
function(
this,
...
){
this$.log.level;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setLogLevel
##
###########################################################################/**
#
# @RdocMethod setLogLevel
#
# @title "Set the log level for a given PhyloSim object"
#
# \description{
# @get "title".
#
# No logging is performed if the log level is negative. If the log level is zero, the messages passed to
# the \code{Log} method will be writen in the log file. If the log level is positive, the messages passed to
# the \code{Debug} method are saved as well.
#
# The default log level is -1. The specified file will be truncated in the case it already exists.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{value}{The new log level as an integer.}
# \item{...}{Not used.}
# }
#
# \value{
# The new level as an integer vector of length one.
# }
#
# \examples{
# # Create a PhyloSim object
# sim<-PhyloSim();
# # get/set log level
# getLogLevel(sim)
# setLogLevel(sim,0)
# # set/get log level via virtual field
# sim$logLevel<- -1
# sim$logLevel
# }
#
# @author
#
# \seealso{
# getLogLevel PhyloSim
# }
#
#*/###########################################################################
setMethodS3(
"setLogLevel",
class="PhyloSim",
function(
this,
value,
...
){
if(missing(value)){
throw("No value provided!\n");
}
if((!is.numeric(value)) | length(value) != 1 ){
throw("The new value must be a numeric vector of length 1!\n");
}
else{
# Create/wipe out log file.
if(value >= 0 ){
if(file.access(this$.log.file,mode=0) == c(0)){
warning("The log file already existed and it was wiped out!\n");
}
# Creating the associated connection:
this$.log.connection<-file(paste(this$.log.file),"w+");
}
this$.log.level<-value;
}
return(this$.log.level);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .getMessageTemplate
##
setMethodS3(
".getMessageTemplate",
class="PhyloSim",
function(
this,
...
){
template<-list(
time=paste("[",Sys.time(),"]",sep=""),
level="Info",
event=""
);
return(template);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .logMessage
##
setMethodS3(
".logMessage",
class="PhyloSim",
function(
this,
message,
...
){
if(missing(message)){
throw("No message given!\n");
}
else if (!is.list(message)){
throw("The message should be a list");
}
else if( length(intersect(names(message),c("time","level","event"))) != 3){
throw("The \"time\", \"level\" and \"event\" elements are mandatory in the message list!\n");
}
else {
writeLines(paste(message[["time"]]," "),con=this$.log.connection,sep="");
message[["time"]]<-NULL;
writeLines(paste(message[["level"]]," "),con=this$.log.connection,sep="");
message[["level"]]<-NULL;
writeLines(paste(message[["event"]]," "),con=this$.log.connection,sep="");
message[["event"]]<-NULL;
writeLines(paste(message,collapse=", "),con=this$.log.connection,sep="");
writeLines("\n",con=this$.log.connection,sep="");
return(TRUE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: Log
##
###########################################################################/**
#
# @RdocMethod Log
#
# @title "Save a message in the PhyloSim log file"
#
# \description{
# @get "title".
#
# The message is written to the log file only if the log level is non-negative. You can use this method for logging
# in the case you write classes for PhyloSim.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{message}{A character vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The message (invisible).
# }
#
# \examples{
# # create a PhyloSim object,
# # with logLevel set to zero
# sim<-PhyloSim(log.level=0);
# # log a message
# Log(sim,"Hiya there!");
# # close log connection
# close(sim$.log.connection)
# # print out the log file
# cat(paste(scan(file=sim$LogFile,what=character(),sep="\n"),collapse="\n"));cat("\n");
# # clean up
# unlink(sim$logFile)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"Log",
class="PhyloSim",
function(
this,
message,
...
){
if(this$.log.level < 0){
return(invisible(FALSE))
}
if(missing(message)){
throw("No message given!\n");
} else {
template<-.getMessageTemplate(this);
template$level<-"Info";
message<-c(template,as.list(message));
.logMessage(this, message);
return(invisible(message));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: Debug
##
###########################################################################/**
#
# @RdocMethod Debug
#
# @title "Save a debug message in the PhyloSim log file"
#
# \description{
# @get "title".
#
# The debug message is written to the log file only if the log level is non-negative. You can use this method for logging
# debug messages in the case you write classes for PhyloSim.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{message}{A character vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The message (invisible).
# }
#
# \examples{
# # create a PhyloSim object,
# # with logLevel set to zero
# sim<-PhyloSim(log.level=0);
# # log a debug message
# Debug(sim,"Some useful detail...");
# # close log connection
# close(sim$.log.connection)
# # print out the log file
# cat(paste(scan(file=sim$LogFile,what=character(),sep="\n"),collapse="\n"));cat("\n");
# # clean up
# unlink(sim$logFile)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"Debug",
class="PhyloSim",
function(
this,
message,
...
){
if(missing(message)){
throw("No message given!\n");
}
else if( this$.log.level <= 0){
return(invisible(FALSE))
}
else {
template<-.getMessageTemplate(this);
template$level<-"DEBUG";
message<-c(template,as.list(message));
.logMessage(this, message);
return(invisible(message));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .UpdateBranchStats
##
setMethodS3(
".UpdateBranchStats",
class="PhyloSim",
function(
this,
event,
details,
branch.number,
...
){
if(details$type == "substitution"){
if(details$accepted) {
if(is.null(this$.branch.stats[[as.character(branch.number)]]$substitution)){
this$.branch.stats[[as.character(branch.number)]]$substitution<-1;
} else {
this$.branch.stats[[as.character(branch.number)]]$substitution<-(this$.branch.stats[[as.character(branch.number)]]$substitution + 1);
}
name<-event$name;
if(is.null(this$.branch.stats[[as.character(branch.number)]][[name]])){
this$.branch.stats[[as.character(branch.number)]][[name]]<-1;
}
else {
this$.branch.stats[[as.character(branch.number)]][[name]]<-(this$.branch.stats[[as.character(branch.number)]][[name]] + 1);
}
}
# Special stuff for the GY94 codon model:
if(is.GY94(event$.process)){
# Increment synonymous counter:
if(event$.type == "synonymous"){
if(is.null(this$.branch.stats[[as.character(branch.number)]][["nr.syn.subst"]])){
# First event of this type on this branch, initialize the list element to 1.
this$.branch.stats[[as.character(branch.number)]][["nr.syn.subst"]]<-1;
}
else {
this$.branch.stats[[as.character(branch.number)]][["nr.syn.subst"]]<-(this$.branch.stats[[as.character(branch.number)]][["nr.syn.subst"]] + 1);
}
}
# Increment non-synonymous counter:
else if(event$.type == "non-synonymous"){
if(is.null(this$.branch.stats[[as.character(branch.number)]][["nr.nsyn.subst"]])){
# First event of this type on this branch, initialize the list element to 1.
this$.branch.stats[[as.character(branch.number)]][["nr.nsyn.subst"]]<-1;
}
else {
this$.branch.stats[[as.character(branch.number)]][["nr.nsyn.subst"]]<-(this$.branch.stats[[as.character(branch.number)]][["nr.nsyn.subst"]] + 1);
}
} else {
throw("The event generated by the GY94 has no type!\n");
}
}
}
else if(details$type == "deletion"){
if(is.null(this$.branch.stats[[as.character(branch.number)]]$deletion)){
this$.branch.stats[[as.character(branch.number)]]$deletion<-1;
}
else {
this$.branch.stats[[as.character(branch.number)]]$deletion<-(this$.branch.stats[[as.character(branch.number)]]$deletion + 1);
}
}
else if(details$type == "insertion"){
if(is.null(this$.branch.stats[[as.character(branch.number)]]$insertion)){
this$.branch.stats[[as.character(branch.number)]]$insertion<-1;
}
else {
this$.branch.stats[[as.character(branch.number)]]$insertion<-(this$.branch.stats[[as.character(branch.number)]]$insertion + 1);
}
}
else {
throw("Invalid event type!\n");
}
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getBranchEvents
##
###########################################################################/**
#
# @RdocMethod getBranchEvents
#
# @title "Get the list of events having per-branch statistics recorded"
#
# \description{
# @get "title".
#
# During simulation the number of events performed on every branch is recorded. The recorded events can be "basic"
# events, like "insertion", "deletion" and "A->T" or events which are sums of basic events, like "substituion". The
# \code{getBranchEvents} method returns a character vector with the names of the events having per-branch
# statistics recorded. The method should be called after the simulation is finished.
#
# The per-branch statistics can be exported as phylo objects by using the \code{exportStatTree} method.
# The branch lengths of the exported phylo objects are set to the value of the respective per-branch event count.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector.
# }
#
# \examples{
# # Create a PhyloSim object.
# # Provide the phylo object
# # and the root sequence.
#
# # NOTE: this will be a little bit slow
# sim<-PhyloSim(
# phylo=rcoal(3),
# root.seq=CodonSequence(
# string="ATGATTATT",
# processes=list(list(GY94(kappa=2,omega.default=0.5))))
# );
# # make the tree longer to have more events
# scaleTree(sim,5)
# # plot the tree
# plot(sim)
# # run simulation
# Simulate(sim)
# # get the list of recorded per-branch event counts
# getBranchEvents(sim)
# # export the number of subtitions as a phylo object
# subst<-exportStatTree(sim,"substitution")
# # plot the exported phylo object
# plot(subst)
# #export the number of synonymous substitutions as a phylo object
# subst<-exportStatTree(sim,"nr.syn.subst")
# # plot the exported phylo object
# plot(subst)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getBranchEvents",
class="PhyloSim",
function(
this,
...
){
tmp<-character();
for(branch in this$.branch.stats){
tmp<-c(tmp,names(branch));
}
return(unique(sort(tmp)));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setBranchEvents
##
###########################################################################/**
#
# @RdocMethod setBranchEvents
#
# @title "Forbidden action: setting the list of events having per-branch statistics recorded"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setBranchEvents",
class="PhyloSim",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: exportStatTree
##
###########################################################################/**
#
# @RdocMethod exportStatTree
#
# @title "Export the per-branch counts of an event as a phylo object"
#
# \description{
# @get "title".
#
# During simulation the number of events performed on every branch is recorded. The recorded events can be "basic"
# events, like "insertion", "deletion" and "A->T" or events which are sums of basic events, like "substituion". The
# \code{getBranchEvents} method returns a character vector with the names of the events having per-branch
# statistics recorded. The method should be called after the simulation is finished.
#
# The per-branch statistics can be exported as phylo objects by using the \code{exportStatTree} method.
# The branch lengths of the exported phylo objects are set to the value of the respective per-branch event count.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{event}{The name of the event as returned by the \code{getBranchEvents} method.}
# \item{...}{Not used.}
# }
#
# \value{
# A phylo object.
# }
#
# \examples{
# # Create a PhyloSim object.
# # Provide the phylo object
# # and the root sequence.
#
# # NOTE: this will be a little bit slow
# sim<-PhyloSim(
# phylo=rcoal(3),
# root.seq=CodonSequence(
# string="ATGATTATT",
# processes=list(list(GY94(kappa=2,omega.default=0.5)))
# )
# );
# # make the tree longer to have more events
# scaleTree(sim,5)
# # plot the tree
# plot(sim)
# # run simulation
# Simulate(sim)
# # get the list of recorded per-branch event counts
# getBranchEvents(sim)
# # export the number of substitutions as a phylo object
# subst<-exportStatTree(sim,"substitution")
# # plot the exported phylo object
# plot(subst)
# #export the number of synonymous substitutions as a phylo object
# subst<-exportStatTree(sim,"nr.syn.subst")
# # plot the exported phylo object
# plot(subst)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"exportStatTree",
class="PhyloSim",
function(
this,
event,
...
){
if(!is.matrix(this$.alignment)){
throw("Simulation is not complete, cannot export statistics!\n");
}
else if(missing(event)){
throw("No event name specified!\n");
}
else if(length(intersect(event, this$branchEvents)) != 1 ){
throw("Invalid event name!");
}
else {
phylo.copy<-this$phylo;
phylo.copy$edge.length<-.getStatBrlen(this, event);
return(phylo.copy);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .getStatBrlen
##
setMethodS3(
".getStatBrlen",
class="PhyloSim",
function(
this,
event,
...
){
tmp<-numeric();
for(i in dimnames(this$edges)[[1]]){
if(is.null(this$.branch.stats[[i]][[event]])){
tmp[[as.numeric(i)]]<-0;
}
else {
tmp[[as.numeric(i)]]<-this$.branch.stats[[i]][[event]];
}
}
return(tmp);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##### Phylo object interface methods #####
##
## Method: getEdges
##
###########################################################################/**
#
# @RdocMethod getEdges
#
# @title "Get the edge matrix from a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
#
# The rows of the edge matrix contain the nodes connected by the edge and the edge length.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix.
# }
#
# \examples{
# # create a PhyloSim object
# sim<-PhyloSim(phylo=rcoal(5));
# # get the edge matrix
# getEdges(sim)
# # get the edge matrix via virtual field
# sim$edges
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEdges",
class="PhyloSim",
function(
this,
...
){
if(!all(is.na(this$.phylo))){
if(is.phylo(this$.phylo)){
if(length(this$.phylo$edge.length) > 2){
if(attr(this$.phylo, "order") != "cladewise"){
throw("The order of the phylo object is not cladewise! Someone must have been messing with that!\n");
}
}
tmp<-cbind(this$.phylo$edge,this$.phylo$edge.length);
colnames(tmp)<-c("from","to","length");
rownames(tmp)<-1:dim(tmp)[[1]];
return(tmp);
}
else{
throw("The phylo object is invalid!\n");
}
}
else{
throw("The phylo object is not set!\n");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setEdges
##
###########################################################################/**
#
# @RdocMethod setEdges
#
# @title "Forbidden action: setting the edge matrix for a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setEdges",
class="PhyloSim",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getNtips
##
###########################################################################/**
#
# @RdocMethod getNtips
#
# @title "Get the number of the tips form a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a PhyloSim object
# sim<-PhyloSim(phylo=rcoal(5));
# # get the number of tips
# getNtips(sim)
# # get the number of tips via virtual field
# sim$ntips
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getNtips",
class="PhyloSim",
function(
this,
...
){
if(!all(is.na(this$.phylo))){
if(is.phylo(this$.phylo)){
return(length(this$.phylo$tip.label));
}
else{
throw("The phylo object is invalid!\n");
}
}
else{
throw("The phylo object is not set!\n");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setNtips
##
###########################################################################/**
#
# @RdocMethod setNtips
#
# @title "Forbidden action: setting the number of the tips for a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setNtips",
class="PhyloSim",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getTipLabels
##
###########################################################################/**
#
# @RdocMethod getTipLabels
#
# @title "Get the tip labels from a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix containing the tip labels.
# }
#
# \examples{
# # create a PhyloSim object
# sim<-PhyloSim(phylo=rcoal(5));
# # get the tip labels
# getTipLabels(sim)
# # get the tip lables via virtual field
# sim$tipLabels
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getTipLabels",
class="PhyloSim",
function(
this,
...
){
if(!all(is.na(this$.phylo))){
if(is.phylo(this$.phylo)){
tmp<-rbind(this$.phylo$tip.label);
rownames(tmp)<-c("Labels:");
colnames(tmp)<-c(1:length(tmp));
return(tmp);
}
else{
throw("The phylo object is invalid!\n");
}
}
else{
throw("The phylo object is not set!\n");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setTipLabels
##
###########################################################################/**
#
# @RdocMethod setTipLabels
#
# @title "Forbidden action: setting the tip labels for a phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setTipLabels",
class="PhyloSim",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getNodes
##
###########################################################################/**
#
# @RdocMethod getNodes
#
# @title "Get the node identifiers from a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector.
# }
#
# \examples{
# # create a PhyloSim object
# sim<-PhyloSim(phylo=rcoal(5));
# # get the node IDs
# getNodes(sim)
# # get the node IDs via virtual field
# sim$nodes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getNodes",
class="PhyloSim",
function(
this,
...
){
if(!all(is.na(this$.phylo))){
if(is.phylo(this$.phylo)){
# This is dumb but safe:
return(sort(unique(as.vector(this$.phylo$edge))));
}
else{
throw("The phylo object is invalid!\n");
}
}
else{
throw("The phylo object is not set!\n");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getNedges
##
###########################################################################/**
#
# @RdocMethod getNedges
#
# @title "Get the number of edges from phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a PhyloSim object
# sim<-PhyloSim(phylo=rcoal(5));
# # get the number of the edges
# getNedges(sim)
# # get the number of the edges via virtual field
# sim$nedges
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getNedges",
class="PhyloSim",
function(
this,
...
){
if(!all(is.na(this$.phylo))){
if(is.phylo(this$.phylo)){
return(dim(this$.phylo$edge)[[1]]);
}
else{
throw("The phylo object is invalid!\n");
}
}
else{
throw("The phylo object is not set!\n");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setNedges
##
###########################################################################/**
#
# @RdocMethod setNedges
#
# @title "Forbidden action: setting the number of edges for phylo object aggregated by a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setNedges",
class="PhyloSim",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setNodes
##
###########################################################################/**
#
# @RdocMethod setNodes
#
# @title "Forbidden action: setting the node identifiers for a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setNodes",
class="PhyloSim",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getTips
##
###########################################################################/**
#
# @RdocMethod getTips
#
# @title "Get the node identifiers of the tip nodes from a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector.
# }
#
# \examples{
# # create a PhyloSim object
# sim<-PhyloSim(phylo=rcoal(5));
# # get the tip IDs
# getTips(sim)
# # get the tip IDs via virtual field
# sim$tips
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getTips",
class="PhyloSim",
function(
this,
...
){
if(!all(is.na(this$.phylo))){
if(is.phylo(this$.phylo)){
# This is dumb but safe:
#return(sort(unique(as.vector(this$.phylo$edge))));
return(1:(getNtips(this)));
}
else{
throw("The phylo object is invalid!\n");
}
}
else{
throw("The phylo object is not set!\n");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setTips
##
###########################################################################/**
#
# @RdocMethod setTips
#
# @title "Forbidden action: setting the node identifiers of the tip nodes for a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setTips",
class="PhyloSim",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRootNode
##
###########################################################################/**
#
# @RdocMethod getRootNode
#
# @title "Get the identifier of the root node from a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a PhyloSim object
# sim<-PhyloSim(phylo=rcoal(5));
# # get the root node ID
# getRootNode(sim)
# # get the root node ID via virtual field
# sim$rootNode
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRootNode",
class="PhyloSim",
function(
this,
...
){
if(!all(is.na(this$.phylo))){
if(is.phylo(this$.phylo)){
# Relying on cladewise order:
return(this$.phylo$edge[1,1]);
}
else{
throw("The phylo object is invalid!\n");
}
}
else{
throw("The phylo object is not set!\n");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRootNode
##
###########################################################################/**
#
# @RdocMethod setRootNode
#
# @title "Forbidden action: setting the identifier of the root node for a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRootNode",
class="PhyloSim",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: is.tip
##
###########################################################################/**
#
# @RdocMethod is.tip
#
# @title "Check if a node is a tip"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{node}{A node identifier (integer vector of length one).}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
# \examples{
# # create a PhyloSim object
# sim<-PhyloSim(phylo=rcoal(5));
# # check if node 4 is a tip
# is.tip(sim,4)
# # check if node 6 is a tip
# is.tip(sim,6)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"is.tip",
class="PhyloSim",
function(
this,
node=NA,
...
){
if(missing(node)){
throw("No node number specified!\n");
}
else if(!is.numeric(node)){
throw("The node number must be numeric!\n");
}
else {
return(round(node) <= this$ntips);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEdge
##
###########################################################################/**
#
# @RdocMethod getEdge
#
# @title "Get and edge from the edge matrix"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{number}{The edge number.}
# \item{...}{Not used.}
# }
#
# \value{
# The edge as a matrix with a single row.
# }
#
# \examples{
# # create a PhyloSim object
# sim<-PhyloSim(phylo=rcoal(5));
# # get edge number 3
# getEdge(sim,3)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEdge",
class="PhyloSim",
function(
this,
number=NA,
...
){
if(missing(number)){
throw("No object provided!\n");
}
else if(!is.numeric(number)){
throw("The edge number must be numeric!\n");
}
else {
number<-round(number);
tmp<-rbind(c(this$.phylo$edge[number,],this$.phylo$edge.length[number]));
colnames(tmp)<-c("from","to","length");
rownames(tmp)<-c("Edge:");
return(tmp);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getTreeLength
##
###########################################################################/**
#
# @RdocMethod getTreeLength
#
# @title "Get the tree length from a PhyloSim object"
#
# \description{
# @get "title".
#
# This method retruns the sum of the edge lengths stored in the aggregated phylo object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a PhyloSim object
# sim<-PhyloSim(phylo=rcoal(5));
# # get the tree length
# getTreeLength(sim)
# # get tree length via virtual field
# sim$treeLength
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getTreeLength",
class="PhyloSim",
function(
this,
...
){
if(!all(is.na(this$.phylo))){
if(is.phylo(this$.phylo)){
return(sum(this$.phylo$edge.length));
}
else{
throw("The phylo object is invalid!\n");
}
}
else{
throw("The phylo object is not set!\n");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setTreeLength
##
###########################################################################/**
#
# @RdocMethod setTreeLength
#
# @title "Forbidden action: setting the tree length for a PhyloSim object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setTreeLength",
class="PhyloSim",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: scaleTree
##
###########################################################################/**
#
# @RdocMethod scaleTree
#
# @title "Scale the branch lengths of a phylo object aggragted by a PhyloSim object"
#
# \description{
# @get "title".
# This method multiples all the edge lengths by the specified factor.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{factor}{A numeric vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The PhyloSim object (invisible).
# }
#
# \examples{
# # create a PhyloSim object
# sim<-PhyloSim(phylo=rcoal(5));
# # get the tree length
# sim$treeLength
# # scale tree
# scaleTree(sim,10)
# # get the scaled tree length
# sim$treeLength
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"scaleTree",
class="PhyloSim",
function(
this,
factor,
...
){
if(missing(factor)){
throw("No branch length scaling factor specified!\n");
} else if((!is.numeric(factor)) | (length(factor) != 1)){
throw("The scaling factor must be a numeric vector of length 1!\n");
} else if(!is.phylo(this$.phylo)){
throw("The phylo object is not set or it is invalid!\n");
} else {
this$.phylo$edge.length<-(this$.phylo$edge.length * factor);
return(invisible(this));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
###########################################################################/**
#
# @RdocMethod readAlignment
#
# @title "Read alignment from file"
#
# \description{
# @get "title".
#
# This method reads an alignment by using the \code{read.dna} function from the \code{\link{ape}}
# package and stores in the \code{PhyloSim} object. If a tree is already attached to the \code{PhyloSim}
# object, the alignment must at least contain the sequences corresponding to tip nodes (but it
# may also contain additional ancestral sequences).
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{file}{A file name specified by either a variable of mode character, or a double-quoted string.}
# \item{format}{a character string specifying the format of the DNA sequences. Four choices are possible: "interleaved", "sequential", "clustal", or "fasta", or any unambiguous abbreviation of these.}
# \item{...}{Not used.}
# }
#
# \value{
# The PhyloSim object (invisible).
# }
#
# \examples{
# # get a safe file name
# fname<-paste("PhyloSim_dummy_fas_",Sys.getpid(),sep="")
# # write out a fasta alignment
# cat("> t3\nGTCTTT-CG-\n",file=fname);
# cat("> t4\nG--TC-TCGG\n",file=fname,append=TRUE);
# cat("> t2\nG--TC-TCGG\n",file=fname,append=TRUE);
# cat("> t1\nGTC-G-TCGG",file=fname,append=TRUE);
# # construct a PhyloSim object,
# # set the phylo object
# sim<-PhyloSim(phylo=rcoal(4))
# # read the alignment
# readAlignment(sim,fname)
# # remove alignment file
# unlink(fname)
# # plot the tree & alignment
# plot(sim)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"readAlignment",
class="PhyloSim",
function(
this,
file,
format="fasta",
...
){
aln<-toupper(read.dna(file=file,format=format,as.matrix=TRUE,as.character=TRUE));
aln.names<-dimnames(aln)[[1]];
if (!all(is.na(this$.phylo))) {
tip.labels<-this$tipLabels;
length.overlap <- length(intersect(tip.labels,aln.names))
if(length.overlap != length(tip.labels)){
throw("The alignment must contain all sequences corresponding to tip nodes!");
}
if (length(aln.names) > length(tip.labels)) {
warning("Alignment has more sequences than the tree's leaf count -- either it contains ancestral sequences or something is wrong!")
}
}
this$.alignment<-aln;
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAlignmentLength
##
###########################################################################/**
#
# @RdocMethod getAlignmentLength
#
# @title "Get the alignment length from a PhyloSim object"
#
# \description{
# @get "title".
#
# This method retruns the number of columns in the alignment stored in the PhyloSim object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a PhyloSim object and run a simulation:
# sim<-Simulate(
# PhyloSim(phy=rcoal(3),
# root=NucleotideSequence(string="ATGC", proc=list(list(JC69())) ) )
# )
# # get the alignment length
# getAlignmentLength(sim)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAlignmentLength",
class="PhyloSim",
function(
this,
...
){
if(!all(is.na(this$.alignment))){
return(dim(this$.alignment)[2]);
}
else{
throw("The alignment object is not set!\n");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
###########################################################################/**
#
# @RdocMethod readTree
#
# @title "Read tree from file"
#
# \description{
# @get "title".
#
# This method reads a tree by using the \code{read.tree} function from the \code{\link{ape}}
# package and stores in the \code{PhyloSim} object. If an alignment is already attached
# to the \code{PhyloSim} object, it must contain all sequences corresponding to tip nodes.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A PhyloSim object.}
# \item{file}{A file name specified by either a variable of mode character, or a double-quoted string.}
# \item{...}{Not used.}
# }
#
# \value{
# The PhyloSim object (invisible).
# }
#
# \examples{
# # get a safe file name
# fname<-paste("PhyloSim_dummy_fas_",Sys.getpid(),sep="")
# # write out a fasta alignment
# cat("(a,(b,c));",file=fname);
# # construct a PhyloSim object:
# sim<-PhyloSim()
# # read the alignment
# readTree(sim,fname)
# # remove alignment file
# unlink(fname)
# # plot the tree
# plot(sim)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"readTree",
class="PhyloSim",
function(
this,
file,
...
){
tree <- read.tree(file)
if (!any(is.na(this$.alignment))) {
# Check for overlap between leaves and seqs.
aln <- this$.alignment;
aln.names <- dimnames(aln)[[1]];
tip.labels <- tree$tip.label;
aln.tree.overlap <- length(intersect(tip.labels,aln.names))
if(aln.tree.overlap != length(tip.labels)){
throw("The alignment must contain all sequences corresponding to tip nodes!");
}
if (length(aln.names) > length(tip.labels)) {
warning("Alignment has more sequences than the tree's leaf count -- either it contains ancestral sequences or something is wrong!")
}
}
this$.phylo <- tree
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
###########################################################################/**
#
# @RdocMethod Undocumented
# \alias{Undocumented}
# \alias{newMatrix}
# \alias{setEquDist.CodonSubst}
# \alias{BrownianPath}
# \alias{buildFromPAML}
# \alias{checkConsistency}
# \alias{clearStates}
# \alias{areSynonymous}
# \alias{attachHookToNode}
# \alias{attachProcess}
# \alias{attachSeqToNode}
# \alias{copySubSequence}
# \alias{Debug}
# \alias{deleteSubSequence}
# \alias{detachHookFromNode}
# \alias{detachProcess}
# \alias{detachSeqFromNode}
# \alias{enableVirtual}
# \alias{exportStatTree}
# \alias{flagTotalRate}
# \alias{generateInsert}
# \alias{getAcceptBy}
# \alias{getAcceptWin}
# \alias{getAlignment}
# \alias{getAlphabet}
# \alias{getAlphabets}
# \alias{getAlphabet}
# \alias{getAncestral}
# \alias{getAncestral}
# \alias{getBaseFreqs}
# \alias{getBigRate}
# \alias{getBranchEvents}
# \alias{getCodonFreqs}
# \alias{getComments}
# \alias{getCumulativeRates}
# \alias{getCumulativeRatesFromRange}
# \alias{getDeletionTolerance}
# \alias{getDist}
# \alias{getEdge}
# \alias{getEdges}
# \alias{getEquDist}
# \alias{getEventRate}
# \alias{getEventRateAtSite}
# \alias{getEvents}
# \alias{getEventsAtSite}
# \alias{getGenerateBy}
# \alias{getHandler}
# \alias{getId}
# \alias{getInsertHook}
# \alias{getInsertionTolerance}
# \alias{getInsertionTolerance}
# \alias{getKappa}
# \alias{getLength}
# \alias{getLengthParam1}
# \alias{getLengthParam2}
# \alias{getLogFile}
# \alias{getLogLevel}
# \alias{getMatrix}
# \alias{getMaxLength}
# \alias{getMethodsList}
# \alias{getNedges}
# \alias{getNodes}
# \alias{getNtips}
# \alias{getOmegas}
# \alias{getParameterAtSite}
# \alias{getParameterAtSites}
# \alias{getPhylo}
# \alias{getProbs}
# \alias{getProcess}
# \alias{getProcesses}
# \alias{getProposeBy}
# \alias{getQMatrix}
# \alias{getRate}
# \alias{getRateList}
# \alias{getRateMultipliers}
# \alias{getRateParam}
# \alias{getRateParamList}
# \alias{getRootNode}
# \alias{getRootSeq}
# \alias{getScale}
# \alias{getScaledMatrix}
# \alias{getSeqFromNode}
# \alias{getSequence}
# \alias{getSequences}
# \alias{getSite}
# \alias{getSites}
# \alias{getSiteSpecificParamIds}
# \alias{getSiteSpecificParamList}
# \alias{getSize}
# \alias{getSizes}
# \alias{getState}
# \alias{getStates}
# \alias{getString}
# \alias{getSymbolFreqs}
# \alias{getSymbolLength}
# \alias{getSymbols}
# \alias{getTableId}
# \alias{getTargetState}
# \alias{getTemplateSeq}
# \alias{getTheta}
# \alias{getTipLabels}
# \alias{getTips}
# \alias{getToleranceMargin}
# \alias{getTotalRate}
# \alias{getTotalRates}
# \alias{getTotalRatesFromRange}
# \alias{getTransTable}
# \alias{getTreeLength}
# \alias{getType}
# \alias{getUniqueAlphabets}
# \alias{getUniqueProcesses}
# \alias{getWriteProtected}
# \alias{globalConsistencyCheck}
# \alias{hasSiteSpecificParameter}
# \alias{hasSymbols}
# \alias{hasUndefinedRate}
# \alias{insertSequence}
# \alias{intersect}
# \alias{list}
# \alias{isAttached}
# \alias{isEmpty}
# \alias{is}
# \alias{default}
# \alias{isStartCodon}
# \alias{isStopCodon}
# \alias{is}
# \alias{tip}
# \alias{Log}
# \alias{my}
# \alias{all}
# \alias{equal}
# \alias{newAAMatrix}
# \alias{omegaHist}
# \alias{omegaVarM0}
# \alias{omegaVarM1}
# \alias{omegaVarM10Cont}
# \alias{omegaVarM10Cont}
# \alias{omegaVarM2}
# \alias{omegaVarM3}
# \alias{omegaVarM4}
# \alias{Perform}
# \alias{plotParametersAtSites}
# \alias{plot}
# \alias{plusGamma}
# \alias{plusInvGamma}
# \alias{proposeLength}
# \alias{rescaleQMatrix}
# \alias{sampleState}
# \alias{sampleStates}
# \alias{saveAlignment}
# \alias{Scale}
# \alias{scaleTree}
# \alias{setAcceptBy}
# \alias{setAcceptWin}
# \alias{setAlignment}
# \alias{setAlphabet}
# \alias{setAlphabets}
# \alias{setAncestral}
# \alias{setBaseFreqs}
# \alias{setBigRate}
# \alias{setBranchEvents}
# \alias{setCodonFreqs}
# \alias{setCodonFreqs}
# \alias{setComments}
# \alias{setCumulativeRates}
# \alias{setDeletionTolerance}
# \alias{setDist}
# \alias{setEdges}
# \alias{setEquDist}
# \alias{setEquDist}
# \alias{setEvents}
# \alias{setGenerateBy}
# \alias{setHandler}
# \alias{setId}
# \alias{setInsertHook}
# \alias{setInsertionTolerance}
# \alias{setInsertionTolerance}
# \alias{setKappa}
# \alias{setKappa}
# \alias{setLength}
# \alias{setLengthParam1}
# \alias{setLengthParam2}
# \alias{setLogFile}
# \alias{setLogLevel}
# \alias{setMatrix}
# \alias{setMaxLength}
# \alias{setMethodsList}
# \alias{setName}
# \alias{setNedges}
# \alias{setNodes}
# \alias{setNtips}
# \alias{setOmegas}
# \alias{setParameterAtSite}
# \alias{setParameterAtSites}
# \alias{setPhylo}
# \alias{setPosition}
# \alias{setProbs}
# \alias{setProcess}
# \alias{setProcesses}
# \alias{setProposeBy}
# \alias{setQMatrix}
# \alias{setRate}
# \alias{setRateList}
# \alias{setRateMultipliers}
# \alias{setRateParam}
# \alias{setRateParamList}
# \alias{setRootNode}
# \alias{setRootSeq}
# \alias{setScale}
# \alias{setScaledMatrix}
# \alias{setSequence}
# \alias{setSequences}
# \alias{setSite}
# \alias{setSiteSpecificParamIds}
# \alias{setSiteSpecificParamList}
# \alias{setSize}
# \alias{setSizes}
# \alias{setState}
# \alias{setStates}
# \alias{setString}
# \alias{setSymbolLength}
# \alias{setSymbols}
# \alias{setTableId}
# \alias{setTargetState}
# \alias{setTemplateSeq}
# \alias{setTheta}
# \alias{setTipLabels}
# \alias{setTips}
# \alias{setToleranceMargin}
# \alias{setTotalRate}
# \alias{setTotalRates}
# \alias{setTransTable}
# \alias{setTreeLength}
# \alias{setType}
# \alias{setUniqueAlphabets}
# \alias{setUniqueProcesses}
# \alias{setWriteProtected}
# \alias{Simulate}
# \alias{Translate}
# \alias{translateCodon}
# \alias{virtualAssignmentForbidden}
# \alias{intersect.list}
# \alias{is.tip}
# \alias{my.all.equal}
# \alias{plot.PSRoot}
# \alias{revComp}
# \alias{readAlignment}
# \alias{readTree}
# \alias{getOmegaScalingFactor}
# \alias{saveLoadReference}
# \alias{getAlignmentLength}
#
# @title "Undocumented object (PhyloSim package)"
#
# \description{
# @get "title".
#
# See the corresponding specific methods if applicable.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"Undocumented",
class="PhyloSim",
function(
...
){
cat("This method has no documentation!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##
## AnyAlphabet
##
##########################################################################/**
#
# @RdocClass AnyAlphabet
#
# @title "The AnyAlphabet class"
#
# \description{
# This is a special Alphabet class which matches any alphabet.
# The '=='.Alphabet method always returns TRUE when one of the
# compared objects inherits from AnyAlphabet. This behaviour is
# handy when creating processes that have no alphabet preference
# (like a deletion process).
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create some alphabet objects
# a<-BinaryAlphabet()
# b<-NucleotideAlphabet()
# any<-AnyAlphabet()
# # compare objects
# a == b
# any == a
# any == b
# }
#
# @author
#
# \seealso{
# Alphabet
# }
#
#*/###########################################################################
setConstructorS3(
"AnyAlphabet",
function(... ){
this<-Alphabet(type="*ANY*",symbols=c());
extend(this,
"AnyAlphabet",
.any.flag=TRUE
);
},
enforceRCC=TRUE
);
##
## BinaryAlphabet
##
##########################################################################/**
#
# @RdocClass BinaryAlphabet
#
# @title "The BinaryAlphabet class"
#
# \description{
# Class of Alphabet objects with the c("0","1") symbol set.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a binary alphabet
# b<-BinaryAlphabet()
# # get alphabet summary
# summary(b)
# }
#
# @author
#
# \seealso{
# Alphabet
# }
#
#*/###########################################################################
setConstructorS3(
"BinaryAlphabet",
function(... ){
this<-Alphabet(type="Binary",symbols=c("0","1"));
extend(this,"BinaryAlphabet");
},
enforceRCC=TRUE
);
##
## NucleotideAlphabet
##
##########################################################################/**
#
# @RdocClass NucleotideAlphabet
#
# @title "The NucleotideAlphabet class"
#
# \description{
# Class of Alphabet objects with the c("T","C","A","G") symbol
# set, representing nucleotides.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a nucleotide alphabet
# b<-NucleotideAlphabet()
# # get alphabet summary
# summary(b)
# }
#
# @author
#
# \seealso{
# Alphabet
# }
#
#*/###########################################################################
setConstructorS3(
"NucleotideAlphabet",
function(... ){
this<-Alphabet(type="Nucleotide",symbols=c("T","C","A","G"));
extend(this,"NucleotideAlphabet");
},
enforceRCC=TRUE
);
##
## AminoAcidAlphabet
##
##########################################################################/**
#
# @RdocClass AminoAcidAlphabet
#
# @title "The AminoAcidAlphabet class"
#
# \description{
# Class of Alphabet objects representing amino acids, using the
# one-letter IUPAC amino acid codes as symbol set:
# \preformatted{
# IUPAC code Amino acid
#
# A Alanine
# C Cysteine
# D Aspartic Acid
# E Glutamic Acid
# F Phenylalanine
# G Glycine
# H Histidine
# I Isoleucine
# K Lysine
# L Leucine
# M Methionine
# N Asparagine
# P Proline
# Q Glutamine
# R Arginine
# S Serine
# T Threonine
# V Valine
# W Tryptophan
# Y Tyrosine
#}
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# a<-AminoAcidAlphabet();
# # get object summary
# summary(a)
# }
#
# @author
#
# \seealso{
# Alphabet
# }
#
#*/###########################################################################
setConstructorS3(
"AminoAcidAlphabet",
function(... ){
this<-Alphabet(
type="Amino acid",
symbols=c(
"A",
"R",
"N",
"D",
"C",
"Q",
"E",
"G",
"H",
"I",
"L",
"K",
"M",
"F",
"P",
"S",
"T",
"W",
"Y",
"V"
)
);
extend(this,"AminoAcidAlphabet");
},
enforceRCC=TRUE
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##
## BinarySequence
##
##########################################################################/**
#
# @RdocClass BinarySequence
#
# @title "The BinarySequence class"
#
# \description{
# Sequence objects aggregating Site objects having a BinaryAlphabet attached by default.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Name of the Sequence object.}
# \item{string}{A string specifying the length and the states of the Sequence object.}
# \item{length}{The length of the sequence. Mutually exclusive with "string".}
# \item{processes}{A list of lists of Process objects, to be attached to the aggregated Site objects. Recycled if shorter than the length of the sequence.}
# \item{ancestral.obj}{The ancestral object of the Sequence object (a valid Sequence or Process object).}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create an empty BinarySequence object
# s<-BinarySequence(length=50)
# s
# # set states
# s$states<-c(0,0,1,0,1,1)
# s
# # create a sequence object by specifying a string
# s<-BinarySequence(string="00000110010001111")
# s
# }
#
# @author
#
# \seealso{
# Sequence BinaryAlphabet
# }
#
#*/###########################################################################
setConstructorS3(
"BinarySequence",
function(
name=NA,
string=NA,
length=NA,
processes=NA,
ancestral.obj=NA,
...
){
if(!missing(string)){
this<-Sequence(string=string,alphabets=list(BinaryAlphabet()));
}
else if(!missing(length)) {
this<-Sequence(length=length,alphabets=list(BinaryAlphabet()));
}
else {
this<-Sequence(alphabets=list(BinaryAlphabet()));
}
this<-extend(this, "BinarySequence");
if(!missing(name)){
this$name<-name;
}
if(!missing(processes)){
setProcesses(this,processes);
}
if(!missing(ancestral.obj)){
this$.ancestral<-ancestral.obj;
}
return(this);
},
enforceRCC=TRUE
);
##
## NucleotideSequence
##
##########################################################################/**
#
# @RdocClass NucleotideSequence
#
# @title "The NucleotideSequence class"
#
# \description{
# Sequence objects aggregating Site objects having a NucleotideAlphabet attached by default.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Name of the Sequence object.}
# \item{string}{A string specifying the length and the states of the Sequence object.}
# \item{length}{The length of the sequence. Mutually exclusive with "string".}
# \item{processes}{A list of lists of Process objects, to be attached to the aggregated Site objects. Recycled if shorter than the length of the sequence.}
# \item{ancestral.obj}{The ancestral object of the Sequence object (a valid Sequence or Process object).}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create an empty NucleotideSequence object
# s<-NucleotideSequence(length=50)
# s
# # set states
# s$states<-c("A","A","G","T")
# s
# # create a sequence object by specifying a string
# s<-NucleotideSequence(string="ATGCCGATTAGCAAA")
# s
# }
#
# @author
#
# \seealso{
# Sequence NucleotideAlphabet
# }
#
#*/###########################################################################
setConstructorS3(
"NucleotideSequence",
function(
name=NA,
string=NA,
length=NA,
processes=NA,
ancestral.obj=NA,
...
){
if(!missing(string)){
this<-Sequence(string=string,alphabets=list(NucleotideAlphabet()));
}
else if(!missing(length)) {
this<-Sequence(length=length,alphabets=list(NucleotideAlphabet()));
}
else {
this<-Sequence(alphabets=list(NucleotideAlphabet()));
}
this<-extend(this, "NucleotideSequence");
if(!missing(name)){
this$name<-name;
}
if(!missing(processes)){
setProcesses(this,processes);
}
if(!missing(ancestral.obj)){
this$.ancestral<-ancestral.obj;
}
return(this);
},
enforceRCC=TRUE
);
##
## revComp
##
###########################################################################/**
#
# @RdocMethod revComp
#
# @title "Reverse complmenet a NucleotideSequence object"
#
# \description{
# @get "title".
#
# The method reverse complements the sequence "in place", no object cloning is performed.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A NucleotideSequence object}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE.
# }
#
# \examples{
# s<-NucleotideSequence(string="ATGC")
# s
# revComp(s)
# s
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"revComp",
class="NucleotideSequence",
function(
this,
...
){
states<-rev(as.character(getStates(this)));
len<-length(states);
if(len == 0){return(invisible(TRUE))}
for(i in 1:len){
if(states[[i]] == "NA"){
state<-NA;
}
else if(states[i] == "A"){
state<-"T";
}
else if(states[i] == "T"){
state<-"A";
}
else if(states[i] == "G"){
state<-"C";
}
else if(states[i] == "C"){
state<-"G";
} else {
throw("Symbol not in NucleotideAlphabet!");
}
this$.sites[[i]]$.state<-state;
}
return(invisible(TRUE));
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## AminoAcidSequence
##
##########################################################################/**
#
# @RdocClass AminoAcidSequence
#
# @title "The AminoAcidSequence class"
#
# \description{
# Sequence objects aggregating Site objects having an AminoAcidAlphabet attached by default.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Name of the Sequence object.}
# \item{string}{A string specifying the length and the states of the Sequence object.}
# \item{length}{The length of the sequence. Mutually exclusive with "string".}
# \item{processes}{A list of lists of Process objects, to be attached to the aggregated Site objects. Recycled if shorter than the length of the sequence.}
# \item{ancestral.obj}{The ancestral object of the Sequence object (a valid Sequence or Process object).}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create an empty AminoAcidSequence object
# s<-AminoAcidSequence(length=50)
# s
# # set states
# s$states<-c("C","C","G","Y")
# s
# # create a sequence object by specifying a string
# s<-AminoAcidSequence(string="CNGGYCCNGYYYY")
# s
# }
#
# @author
#
# \seealso{
# Sequence AminoAcidAlphabet
# }
#
#*/###########################################################################
setConstructorS3(
"AminoAcidSequence",
function(
name=NA,
string=NA,
length=NA,
processes=NA,
ancestral.obj=NA,
...
){
if(!missing(string)){
this<-Sequence(string=string,alphabets=list(AminoAcidAlphabet()));
}
else if(!missing(length)) {
this<-Sequence(length=length,alphabets=list(AminoAcidAlphabet()));
}
else {
this<-Sequence(alphabets=list(AminoAcidAlphabet()));
}
this<-extend(this, "AminoAcidSequence");
if(!missing(name)){
this$name<-name;
}
if(!missing(processes)){
setProcesses(this,processes);
}
if(!missing(ancestral.obj)){
this$.ancestral<-ancestral.obj;
}
return(this);
},
enforceRCC=TRUE
);
##
## CodonSequence
##
##########################################################################/**
#
# @RdocClass CodonSequence
#
# @title "The CodonSequence class"
#
# \description{
# Sequence objects aggregating Site objects having a CodonAlphabet attached by default.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{Name of the Sequence object.}
# \item{string}{A string specifying the length and the states of the Sequence object.}
# \item{length}{The length of the sequence. Mutually exclusive with "string".}
# \item{table.id}{The genetic code table to use in the attached CodonAlphabet object ("Standard" by default).}
# \item{processes}{A list of lists of Process objects, to be attached to the aggregated Site objects. Recycled if shorter than the length of the sequence.}
# \item{ancestral.obj}{The ancestral object of the Sequence object (a valid Sequence or Process object).}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create an empty CodonSequence object
# s<-CodonSequence(length=50)
# s
# # set states
# s$states<-c("ATG","CGA","TTT","CTA")
# s
# # create a sequence object by specifying a string
# s<-CodonSequence(string="ATCTTTCGAATG")
# s
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setConstructorS3(
"CodonSequence",
function(
name=NA,
string=NA,
length=NA,
table.id=1,
processes=NA,
ancestral.obj=NA,
...
){
if (!missing(string)){
len<-((stringLength(string)/3));
flen<-floor(len);
this<-Sequence(length=flen,alphabets=list(CodonAlphabet(table.id=table.id)));
if(len > flen){
warning("The length of the provided string was not multiple of 3. The incomplete codon was discarded!\n");
}
nuc<-strsplit(string,"",fixed=TRUE)[[1]];
j<-1; # counter for the codon position
for(i in seq(from=1,to=(flen * 3),by=3)){
# get the codon:
state<-paste(nuc[c(i,i+1,i+2)],collapse="");
# Check for stop codons:
if( isStopCodon(this$.sites[[j]]$.alphabet, state) ){
throw("The CodonSequence objects does not accept stop codons as valid states!\n");
}
# Set the state:
setStates(this,state,j);
j<-j+1;
}
}
else if(!missing(length)){
this<-Sequence(length=length,alphabets=list(CodonAlphabet(table.id=table.id)));
}
else {
this<-Sequence(alphabets=list(CodonAlphabet(table.id=table.id)));
}
this<-extend(this, "CodonSequence");
if(!missing(name)){
this$name<-name;
}
if(!missing(processes)){
setProcesses(this,processes);
}
if(!missing(ancestral.obj)){
this$.ancestral<-ancestral.obj;
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: getOmegas
##
###########################################################################/**
#
# @RdocMethod getOmegas
# \alias{getOmegas.Sequence}
#
# @title "Get the omegas from a collection of sites"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonSequence object.}
# \item{process}{A process object inheriting from GY94.}
# \item{index}{A vector of positions.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector.
# }
#
# \examples{
# # create a GY94 process
# p<-GY94()
# # create a CodonSequence object,
# # attach a process p
# s<-CodonSequence(length=20,processes=list(list(p)))
# # set omega values in range 1:5
# setOmegas(s,p,c(0.5,1,1.5),1:5)
# # get omega values from siutes 1,2,3,10, and 20
# getOmegas(s,p,c(1:3,10,20))
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getOmegas",
class="CodonSequence",
function(
this,
process,
index,
...
){
if(missing(process)){
throw("No process given!\n");
}
else if(!is.GY94(process)){
throw("The specified process is not a GY94 codon substitution process!\n");
}
rm<-getParameterAtSites(this=this,process=process,id="omega",index=index);
return(as.numeric(lapply(rm,function(param){param$value})));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: omegaHist
##
###########################################################################/**
#
# @RdocMethod omegaHist
#
# @title "Plot a histogram of omega values from a range"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonSequence object.}
# \item{process}{A process object inheriting from GY94.}
# \item{breaks}{\code{breaks} parameter for \code{hist()}.}
# \item{index}{A vector of positions.}
# \item{...}{Not used.}
# }
#
# \value{
# The CodonSequence object (invisible).
# }
#
# \examples{
# # create a GY94 process
# p<-GY94()
# # create a CodonSequence object,
# # attach a process p
# s<-CodonSequence(length=20,processes=list(list(p)))
# # set omega values through omegaVarM2.CodonSequence
# omegaVarM2(s,p,p0=0.5,p1=0.2,omega=1.5)
# # get a histogram of omega values from the range 1:15
# omegaHist(s,p,breaks=10,1:15)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"omegaHist",
class="CodonSequence",
function(
this,
process,
breaks,
index,
...
){
if(missing(process)){
throw("No process given!\n");
}
else if(!is.GY94(process)){
throw("The specified process is not a GY94 codon substitution process!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
if(missing(breaks)){
hist(getOmegas(this,process,index));
}
else {
omegas<-getOmegas(this,process,index);
hist(omegas,breaks=breaks,main="Histogram of omega values",xlab="Omega",freq=FALSE);
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setOmegas
###########################################################################/**
#
# @RdocMethod setOmegas
# \alias{setOmegas.Sequence}
#
# @title "Set the omegas for a collection of sites"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonSequence object.}
# \item{process}{A process object inheriting from GY94.}
# \item{value}{A vector containing the new values of the site-process specific parameter, recycled if shorter than the index vector.}
# \item{index}{A vector of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector.
# }
#
# \examples{
# # create a GY94 process
# p<-GY94()
# # create a CodonSequence object,
# # attach a process p
# s<-CodonSequence(length=20,processes=list(list(p)))
# # set omega values in range 1:5
# setOmegas(s,p,c(0.5,1,1.5),1:5)
# # get omega values from siutes 1,2,3,10, and 20
# getOmegas(s,p,c(1:3,10,20))
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setOmegas",
class="CodonSequence",
function(
this,
process,
value,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(value)){
throw("No new value specified!\n");
}
else if(!all(is.numeric(value)) ){
throw("The new value must be a numeric vector!\n");
}
else {
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
setParameterAtSites(this, process=process, id="omega",value=value,index=index);
return(invisible(TRUE));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: omegaVarM0 - one ratio
##
###########################################################################/**
#
# @RdocMethod omegaVarM0
#
# @title "The M0 (one-ratio) model of variable omega ratios among sites"
#
# \description{
# @get "title".
#
# This method sets the \code{omega} site-process specific parameter
# in the specified range to values sampled from the M0 (one-ratio) model of
# variable omega ratios among sites.
#
# Distribution of omega values:
# \preformatted{
# CATEGORY PROBABILITY
#
# omega 1
# }
# }
#
# \references{
# Yang, Z., Nielsen, R., Goldman, N., Pedersen Krabbe, A-M. (2000) Codon-Substitution Models for Heterogeneous Selection Pressure at Amino Acid Sites - Genetics 155:431-449 \url{http://bit.ly/bvjucn}
#
# Goldman, N., Yang, Z. (1994) A codon-based model of nucleotide substitution for protein-coding DNA sequences - Mol Biol Evol 11(5):725-36 \url{http://bit.ly/aSVEoa}
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonSequence object.}
# \item{process}{A process object inheriting from GY94.}
# \item{omega}{The fixed omega value.}
# \item{index}{A vector of positions.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE.
# }
#
# \examples{
# # create a GY94 object
# p<-GY94(kappa=2)
# # create a CodonSequence object, attach process p
# s<-CodonSequence(length=20, processes=list(list(p)))
# # sample states
# sampleStates(s)
# # sample omegas in range 1:5 from model M0
# omegaVarM0(s,p,omega=2,1:5)
# # get omega values
# getOmegas(s,p)
# # get a histogram of omega values in range 1:5
# omegaHist(s,p,breaks=50,1:5)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"omegaVarM0",
class="CodonSequence",
function(
this,
process,
omega,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(omega)){
throw("No new omega value specified!\n");
}
else if((!is.numeric(omega))| (length(omega) != 1)){
throw("The new value must be a numeric vector of length 1!\n");
}
else {
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
setParameterAtSites(this, process=process, id="omega",value=omega,index=index);
return(invisible(TRUE));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: omegaVarM1 - neutral
##
###########################################################################/**
#
# @RdocMethod omegaVarM1
#
# @title "The M1 (neutral) model of variable omega ratios among sites"
#
# \description{
# @get "title".
#
# This method sets the \code{omega} site-process specific parameter
# in the specified range to values sampled from the M1 (neutral) model of
# variable omega ratios among sites.
#
# Distribution of omega values:
# \preformatted{
# CATEGORY PROBABILITY
#
# omega_0 = 0 p0
# omega_1 = 1 1-p0
# }
# }
#
# \references{
# Yang, Z., Nielsen, R., Goldman, N., Pedersen Krabbe, A-M. (2000) Codon-Substitution Models for Heterogeneous Selection Pressure at Amino Acid Sites - Genetics 155:431-449 \url{http://bit.ly/bvjucn}
#
# Goldman, N., Yang, Z. (1994) A codon-based model of nucleotide substitution for protein-coding DNA sequences - Mol Biol Evol 11(5):725-36 \url{http://bit.ly/aSVEoa}
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonSequence object.}
# \item{process}{A process object inheriting from GY94.}
# \item{p0}{See above.}
# \item{index}{A vector of positions.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE.
# }
#
# \examples{
# # create a GY94 object
# p<-GY94(kappa=2)
# # create a CodonSequence object, attach process p
# s<-CodonSequence(length=25, processes=list(list(p)))
# # sample states
# sampleStates(s)
# # sample omegas in range 1:20 from model M1
# omegaVarM1(s,p,p0=0.5,1:20)
# # get omega values
# getOmegas(s,p)
# # get a histogram of omega values in range 1:20
# omegaHist(s,p,breaks=50,1:20)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"omegaVarM1",
class="CodonSequence",
function(
this,
process,
p0,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(p0)){
throw("No p0 value specified!\n");
}
else if((!is.numeric(p0))| (length(p0) != 1)){
throw("The new value must be a numeric vector of length 1!\n");
}
else if(p0 < 0 | p0 > 1){
throw("The p0 parameter must be in the [0,1] interval!\n");
}
else {
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=sample(c(0,1), size=1, replace=FALSE, prob=c(p0,(1-p0))));
}
return(invisible(TRUE));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: omegaVarM2 - selection
##
###########################################################################/**
#
# @RdocMethod omegaVarM2
#
# @title "The M2 (selection) model of variable omega ratios among sites"
#
# \description{
# @get "title".
#
# This method sets the \code{omega} site-process specific parameter
# in the specified range to values sampled from the M2 (selection) model of
# variable omega ratios among sites.
#
# Distribution of omega values:
# \preformatted{
# CATEGORY PROBABILITY
#
# omega_0 = 0 p0
# omega_1 = 1 p1
# omega_2 1-p0-p1
# }
# }
#
# \references{
# Yang, Z., Nielsen, R., Goldman, N., Pedersen Krabbe, A-M. (2000) Codon-Substitution Models for Heterogeneous Selection Pressure at Amino Acid Sites - Genetics 155:431-449 \url{http://bit.ly/bvjucn}
#
# Goldman, N., Yang, Z. (1994) A codon-based model of nucleotide substitution for protein-coding DNA sequences - Mol Biol Evol 11(5):725-36 \url{http://bit.ly/aSVEoa}
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonSequence object.}
# \item{process}{A process object inheriting from GY94.}
# \item{p0}{See above.}
# \item{p1}{See above.}
# \item{omega_2}{See above.}
# \item{index}{A vector of positions.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE.
# }
#
# \examples{
# # create a GY94 object
# p<-GY94(kappa=2)
# # create a CodonSequence object, attach process p
# s<-CodonSequence(length=25, processes=list(list(p)))
# # sample states
# sampleStates(s)
# # sample omegas in range 1:20 from model M2
# omegaVarM2(s,p,p0=0.2,p1=0.3,omega_2=4,1:20)
# # get omega values
# getOmegas(s,p)
# # get a histogram of omega values in range 1:20
# omegaHist(s,p,breaks=50,1:20)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"omegaVarM2",
class="CodonSequence",
function(
this,
process,
p0,
p1,
omega_2,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(p0)){
throw("No p0 value specified!\n");
}
else if((!is.numeric(p0))| (length(p0) != 1)){
throw("The p0 value must be a numeric vector of length 1!\n");
}
else if(p0 < 0 | p0 > 1){
throw("The p0 parameter must be in the [0,1] interval!\n");
}
else if(missing(p1)){
throw("No p1 value specified!\n");
}
else if((!is.numeric(p1))| (length(p1) != 1)){
throw("The p1 value must be a numeric vector of length 1!\n");
}
else if(p1 < 0 | p1 > 1){
throw("The p1 parameter must be in the [0,1] interval!\n");
}
else if(missing(omega_2)){
throw("No omega value specified!\n");
}
else if((!is.numeric(omega_2))| (length(omega_2) != 1)){
throw("The omega value must be a numeric vector of length 1!\n");
}
else {
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=sample(c(0,1,omega_2), size=1, replace=FALSE, prob=c(p0,p1,(1-p0-p1))));
}
return(invisible(TRUE));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: omegaVarM3 - discrete
##
###########################################################################/**
#
# @RdocMethod omegaVarM3
#
# @title "The M3 (discrete) model of variable omega ratios among sites"
#
# \description{
# @get "title".
#
# This method sets the \code{omega} site-process specific parameter
# in the specified range to values sampled from the M3 (discrete) model of
# variable omega ratios among sites.
#
# Distribution of omega values:
# \preformatted{
# CATEGORY PROBABILITY
#
# omega_0 p0
# omega_1 p1
# omega_2 p2
# ... ...
# omega_k pk
# }
# }
#
# \references{
# Yang, Z., Nielsen, R., Goldman, N., Pedersen Krabbe, A-M. (2000) Codon-Substitution Models for Heterogeneous Selection Pressure at Amino Acid Sites - Genetics 155:431-449 \url{http://bit.ly/bvjucn}
#
# Goldman, N., Yang, Z. (1994) A codon-based model of nucleotide substitution for protein-coding DNA sequences - Mol Biol Evol 11(5):725-36 \url{http://bit.ly/aSVEoa}
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonSequence object.}
# \item{process}{A process object inheriting from GY94.}
# \item{omegas}{A vector of omega values (omega_0 ... omega_k).}
# \item{probs}{A vector of probabilities (p0 ... pk).}
# \item{index}{A vector of positions.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE.
# }
#
# \examples{
# # create a GY94 object
# p<-GY94(kappa=2)
# # create a CodonSequence object, attach process p
# s<-CodonSequence(length=25, processes=list(list(p)))
# # sample states
# sampleStates(s)
# # sample omegas in range 1:20 from model M3
# omegaVarM3(s,p,omegas=c(0,2,4),probs=c(1/3,1/3,1/3),1:20)
# # get omega values
# getOmegas(s,p)
# # get a histogram of omega values in range 1:20
# omegaHist(s,p,breaks=50,1:20)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"omegaVarM3",
class="CodonSequence",
function(
this,
process,
omegas,
probs,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(omegas)){
throw("No omega values specified!\n");
}
else if((!is.numeric(omegas))){
throw("The omegas must be numeric!\n");
}
else if(missing(probs)){
throw("No probabilities specified!\n");
}
else if(!is.numeric(probs)){
throw("The probabilities must be numeric!\n");
}
else if(length(omegas) != length(probs)){
throw("The length of the \"omegas\" and \"probs\" vector must be the same!\n");
}
else if(!PSRoot$my.all.equal(sum(probs),1.0)){
probs<-(probs/sum(probs));
warning("The provided probabilities were scaked in order to sum to one!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=sample(omegas, size=1, replace=FALSE, prob=probs));
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: omegaVarM4 - freqs
##
###########################################################################/**
#
# @RdocMethod omegaVarM4
#
# @title "The M4 (freqs) model of variable omega ratios among sites"
#
# \description{
# @get "title".
#
# This method sets the \code{omega} site-process specific parameter
# in the specified range to values sampled from the M4 (freqs) model of
# variable omega ratios among sites.
#
# Distribution of omega values:
# \preformatted{
# CATEGORY PROBABILITY
#
# omega_0 = 0 p0
# omega_1 = 1/3 p1
# omega_2 = 2/3 p2
# omega_3 = 1 p3
# omega_4 = 3 p4
# }
# }
#
# \references{
# Yang, Z., Nielsen, R., Goldman, N., Pedersen Krabbe, A-M. (2000) Codon-Substitution Models for Heterogeneous Selection Pressure at Amino Acid Sites - Genetics 155:431-449 \url{http://bit.ly/bvjucn}
#
# Goldman, N., Yang, Z. (1994) A codon-based model of nucleotide substitution for protein-coding DNA sequences - Mol Biol Evol 11(5):725-36 \url{http://bit.ly/aSVEoa}
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonSequence object.}
# \item{process}{A process object inheriting from GY94.}
# \item{probs}{A vector of probabilities (p0 ... p4).}
# \item{index}{A vector of positions.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE.
# }
#
# \examples{
# # create a GY94 object
# p<-GY94(kappa=2)
# # create a CodonSequence object, attach process p
# s<-CodonSequence(length=25, processes=list(list(p)))
# # sample states
# sampleStates(s)
# # sample omegas in range 1:20 from model M4
# omegaVarM4(s,p,probs=c(2/5,1/5,1/5,1/10,1/10),1:20)
# # get omega values
# getOmegas(s,p)
# # get a histogram of omega values in range 1:20
# omegaHist(s,p,breaks=50,1:20)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"omegaVarM4",
class="CodonSequence",
function(
this,
process,
probs,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(probs)){
throw("No probabilities specified!\n");
}
else if(!is.numeric(probs)){
throw("The probs must be greater than zero!\n");
}
else if( length(probs) != 5){
throw("The length of the \"probs\" vector must be 5!\n");
}
else if(!PSRoot$my.all.equal(sum(probs),1.0)){
probs<-(probs/sum(probs));
warning("The provided probabilities were scaked in order to sum to one!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
omegas<-c(0,(1/3),(2/3),1,3);
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=sample(omegas, size=1, replace=FALSE, prob=probs));
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .omegaVarM5Cont - gamma
##
setMethodS3(
".omegaVarM5Cont",
class="CodonSequence",
function(
this,
process,
alpha,
beta,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(alpha)){
throw("No alpha (shape) value specified!\n");
}
else if((!is.numeric(alpha)) | (length(alpha) != 1)){
throw("The alpha (shape) parameter must be a numeric vector of length 1!\n");
}
else if(alpha < 0){
throw("The alpha (shape) must be greater than zero!\n");
}
else if(missing(beta)){
throw("No beta (scale) value specified!\n");
}
else if((!is.numeric(beta)) | (length(beta) != 1)){
throw("The beta (scale) parameter must be a numeric vector of length 1!\n");
}
else if(beta <= 0){
throw("The beta (scale) must be strictly positive!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=rgamma(1,shape=alpha,scale=beta));
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .omegaVarM6Cont - 2gamma
##
setMethodS3(
".omegaVarM6Cont",
class="CodonSequence",
function(
this,
process,
p0,
alpha0,
beta0,
alpha1,
beta1,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(p0)){
throw("No p0 value specified!\n");
}
else if((!is.numeric(p0)) | (length(p0) != 1)){
throw("The p0 parameter must be a numeric vector of length 1!\n");
}
else if( (p0 < 0) | (p0 > 1)){
throw("p0 must be in the [0,1] interval!\n");
}
else if(missing(alpha0)){
throw("No alpha0 (shape0) value specified!\n");
}
else if((!is.numeric(alpha0)) | (length(alpha0) != 1)){
throw("The alpha0 (shape0) parameter must be a numeric vector of length 1!\n");
}
else if(alpha0 < 0){
throw("The alpha0 (shape0) must be greater than zero!\n");
}
else if(missing(beta0)){
throw("No beta0 (scale0) value specified!\n");
}
else if((!is.numeric(beta0)) | (length(beta0) != 1)){
throw("The beta0 (scale0) parameter must be a numeric vector of length 1!\n");
}
else if(beta0 <= 0){
throw("The beta0 (scale0) must be strictly positive!\n");
}
else if(missing(alpha1)){
throw("No alpha1 (shape1) value specified!\n");
}
else if((!is.numeric(alpha1)) | (length(alpha1) != 1)){
throw("The alpha1 (shape1) parameter must be a numeric vector of length 1!\n");
}
else if(alpha1 < 0){
throw("The alpha1 (shape1) must be greater than zero!\n");
}
else if(missing(beta1)){
throw("No beta1 (scale1) value specified!\n");
}
else if((!is.numeric(beta1)) | (length(beta1) != 1)){
throw("The beta1 (scale1) parameter must be a numeric vector of length 1!\n");
}
else if(beta1 <= 0){
throw("The beta1 (scale1) must be strictly positive!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=sample(c(rgamma(1,shape=alpha0,scale=beta0),rgamma(1,shape=alpha1,scale=beta1)),size=1,replace=FALSE,prob=c(p0,(1-p0)) ));
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .omegaVarM7Cont - beta
##
setMethodS3(
".omegaVarM7",
class="CodonSequence",
function(
this,
process,
p,
q,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(p)){
throw("No p value specified!\n");
}
else if((!is.numeric(p)) | (length(p) != 1)){
throw("The p parameter must be a numeric vector of length 1!\n");
}
else if(p < 0){
throw("The p parameter must be greater than zero!\n");
}
else if(missing(q)){
throw("No q value specified!\n");
}
else if((!is.numeric(q)) | (length(q) != 1)){
throw("The q parameter must be a numeric vector of length 1!\n");
}
else if(q < 0){
throw("The q parameter must be positive!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=rbeta(1,shape1=p,shape2=q));
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .omegaVarM8Cont - beta&omega
##
setMethodS3(
".omegaVarM8Cont",
class="CodonSequence",
function(
this,
process,
p0,
p,
q,
omega,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(p0)){
throw("No p0 value specified!\n");
}
else if((!is.numeric(p0)) | (length(p0) != 1)){
throw("The p0 parameter must be a numeric vector of length 1!\n");
}
else if( (p0 < 0) | (p0 > 1)){
throw("The p0 parameter must be from the [0,1] interval!\n");
}
else if(missing(p)){
throw("No p value specified!\n");
}
else if((!is.numeric(p)) | (length(p) != 1)){
throw("The p parameter must be a numeric vector of length 1!\n");
}
else if(p < 0){
throw("The p parameter must be greater than zero!\n");
}
else if(missing(q)){
throw("No q value specified!\n");
}
else if((!is.numeric(q)) | (length(q) != 1)){
throw("The q parameter must be a numeric vector of length 1!\n");
}
else if(q < 0){
throw("The q parameter must be positive!\n");
}
else if(missing(omega)){
throw("No omega value specified!\n");
}
else if((!is.numeric(omega)) | (length(omega) != 1)){
throw("The omega parameter must be a numeric vector of length 1!\n");
}
else if(omega < 0){
throw("The omega parameter must be positive!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=sample(c(rbeta(1,shape1=p,shape2=q),omega),size=1,replace=FALSE,prob=(c(p0,(1-p0)))));
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .omegaVarM9 - beta&gamma
##
setMethodS3(
".omegaVarM9Cont",
class="CodonSequence",
function(
this,
process,
p0,
p,
q,
alpha,
beta,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(p0)){
throw("No p0 value specified!\n");
}
else if((!is.numeric(p0)) | (length(p0) != 1)){
throw("The p0 parameter must be a numeric vector of length 1!\n");
}
else if( (p0 < 0) | (p0 > 1)){
throw("p0 must be in the [0,1] interval!\n");
}
else if(missing(p)){
throw("No p value specified!\n");
}
else if((!is.numeric(p)) | (length(p) != 1)){
throw("The p parameter must be a numeric vector of length 1!\n");
}
else if(p < 0){
throw("The p must be greater than zero!\n");
}
else if(missing(q)){
throw("No q value specified!\n");
}
else if((!is.numeric(q)) | (length(q) != 1)){
throw("The q parameter must be a numeric vector of length 1!\n");
}
else if(q < 0){
throw("The q must be greater than zero!\n");
}
else if(missing(alpha)){
throw("No alpha (shape) value specified!\n");
}
else if((!is.numeric(alpha)) | (length(alpha) != 1)){
throw("The alpha (shape) parameter must be a numeric vector of length 1!\n");
}
else if(alpha < 0){
throw("The alpha (shape) must be greater than zero!\n");
}
else if(missing(beta)){
throw("No beta (scale) value specified!\n");
}
else if((!is.numeric(beta)) | (length(beta) != 1)){
throw("The beta (scale) parameter must be a numeric vector of length 1!\n");
}
else if(beta <= 0){
throw("The beta (scale) must be strictly positive!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=sample(c(rbeta(1,shape1=p,shape2=q),rgamma(1,shape=alpha,scale=beta)),size=1,replace=FALSE,prob=c(p0,(1-p0)) ));
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .omegaVarM10Cont - beta&gamma+1
##
setMethodS3(
".omegaVarM10Cont",
class="CodonSequence",
function(
this,
process,
p0,
p,
q,
alpha,
beta,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(p0)){
throw("No p0 value specified!\n");
}
else if((!is.numeric(p0)) | (length(p0) != 1)){
throw("The p0 parameter must be a numeric vector of length 1!\n");
}
else if( (p0 < 0) | (p0 > 1)){
throw("p0 must be in the [0,1] interval!\n");
}
else if(missing(p)){
throw("No p value specified!\n");
}
else if((!is.numeric(p)) | (length(p) != 1)){
throw("The p parameter must be a numeric vector of length 1!\n");
}
else if(p < 0){
throw("The p must be greater than zero!\n");
}
else if(missing(q)){
throw("No q value specified!\n");
}
else if((!is.numeric(q)) | (length(q) != 1)){
throw("The q parameter must be a numeric vector of length 1!\n");
}
else if(q < 0){
throw("The q must be greater than zero!\n");
}
else if(missing(alpha)){
throw("No alpha (shape) value specified!\n");
}
else if((!is.numeric(alpha)) | (length(alpha) != 1)){
throw("The alpha (shape) parameter must be a numeric vector of length 1!\n");
}
else if(alpha < 0){
throw("The alpha (shape) must be greater than zero!\n");
}
else if(missing(beta)){
throw("No beta (scale) value specified!\n");
}
else if((!is.numeric(beta)) | (length(beta) != 1)){
throw("The beta (scale) parameter must be a numeric vector of length 1!\n");
}
else if(beta <= 0){
throw("The beta (scale) must be strictly positive!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
# It's not too elegant to fork the whole method for just shifting the gamma with 1...
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=sample(c(rbeta(1,shape1=p,shape2=q),(1 + rgamma(1,shape=alpha,scale=beta)) ),size=1,replace=FALSE,prob=c(p0,(1-p0)) ));
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .omegaVarM11Cont - beta&normal>1
##
setMethodS3(
".omegaVarM11Cont",
class="CodonSequence",
function(
this,
process,
p0,
p,
q,
mean,
sd,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(p0)){
throw("No p0 value specified!\n");
}
else if((!is.numeric(p0)) | (length(p0) != 1)){
throw("The p0 parameter must be a numeric vector of length 1!\n");
}
else if( (p0 < 0) | (p0 > 1)){
throw("p0 must be in the [0,1] interval!\n");
}
else if(missing(p)){
throw("No p value specified!\n");
}
else if((!is.numeric(p)) | (length(p) != 1)){
throw("The p parameter must be a numeric vector of length 1!\n");
}
else if(p < 0){
throw("The p must be greater than zero!\n");
}
else if(missing(q)){
throw("No q value specified!\n");
}
else if((!is.numeric(q)) | (length(q) != 1)){
throw("The q parameter must be a numeric vector of length 1!\n");
}
else if(q < 0){
throw("The q must be greater than zero!\n");
}
else if(missing(mean)){
throw("No mean specified!\n");
}
else if((!is.numeric(mean)) | (length(mean) != 1)){
throw("The mean parameter must be a numeric vector of length 1!\n");
}
else if(missing(sd)){
throw("No sd value specified!\n");
}
else if((!is.numeric(sd)) | (length(sd) != 1)){
throw("The sd parameter must be a numeric vector of length 1!\n");
}
else if( sd < 0){
throw("The sd parameter must be positive!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
rnorm.gt.1<-function(mean=NA,sd=NA){
# This is probably the most primitive way to truncate the distribution!
tmp<-rnorm(1,mean=mean,sd=sd);
while( tmp <= 1){
tmp<-rnorm(1,mean=mean,sd=sd);
};
return(tmp);
}
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=sample(c(rbeta(1,shape1=p,shape2=q), (rnorm.gt.1(mean=mean,sd=sd))),size=1,replace=FALSE,prob=c(p0,(1-p0)) ));
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .omegaVarM12Cont - 0&2normal>0
##
setMethodS3(
".omegaVarM12Cont",
class="CodonSequence",
function(
this,
process,
p0,
p1,
sd1,
mean2,
sd2,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(p0)){
throw("No p0 value specified!\n");
}
else if((!is.numeric(p0)) | (length(p0) != 1)){
throw("The p0 parameter must be a numeric vector of length 1!\n");
}
else if( (p0 < 0) | (p0 > 1)){
throw("p0 must be in the [0,1] interval!\n");
}
else if(missing(p1)){
throw("No p1 value specified!\n");
}
else if((!is.numeric(p1)) | (length(p1) != 1)){
throw("The p1 parameter must be a numeric vector of length 1!\n");
}
else if( (p1 < 0) | (p1 > 1)){
throw("p1 must be in the [0,1] interval!\n");
}
else if(missing(sd1)){
throw("No sd1 value specified!\n");
}
else if((!is.numeric(sd1)) | (length(sd1) != 1)){
throw("The sd1 parameter must be a numeric vector of length 1!\n");
}
else if( sd1 < 0){
throw("The sd1 parameter must be positive!\n");
}
else if(missing(mean2)){
throw("No mean2 specified!\n");
}
else if((!is.numeric(mean2)) | (length(mean2) != 1)){
throw("The mean2 parameter must be a numeric vector of length 1!\n");
}
else if(missing(sd2)){
throw("No sd2 value specified!\n");
}
else if((!is.numeric(sd2)) | (length(sd2) != 1)){
throw("The sd2 parameter must be a numeric vector of length 1!\n");
}
else if( sd2 < 0){
throw("The sd2 parameter must be positive!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
rnorm.gt.0<-function(mean=NA,sd=NA){
# This is probably the most primitive way to truncate the distribution!
tmp<-rnorm(1,mean=mean,sd=sd);
while( tmp <= 0){
tmp<-rnorm(1,mean=mean,sd=sd);
};
return(tmp);
}
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=sample(
c(0,rnorm.gt.0(mean=1,sd=sd1),rnorm.gt.0(mean=mean2,sd=sd2)),
size=1,
replace=FALSE,
prob=c(p0,((1-p0)*p1),((1-p0)*(1-p1)))
));
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .omegaVarM13Cont - 3normal>0
##
setMethodS3(
".omegaVarM13Cont",
class="CodonSequence",
function(
this,
process,
p0,
p1,
sd0,
sd1,
mean2,
sd2,
index,
...
){
if(missing(process)){
throw("No process specified!\n");
}
if(!is.GY94(process)){
throw("The sepcified process is not a GY94 codon substitution process!\n");
}
else if(missing(p0)){
throw("No p0 value specified!\n");
}
else if((!is.numeric(p0)) | (length(p0) != 1)){
throw("The p0 parameter must be a numeric vector of length 1!\n");
}
else if( (p0 < 0) | (p0 > 1)){
throw("p0 must be in the [0,1] interval!\n");
}
else if(missing(p1)){
throw("No p1 value specified!\n");
}
else if((!is.numeric(p1)) | (length(p1) != 1)){
throw("The p1 parameter must be a numeric vector of length 1!\n");
}
else if( (p1 < 0) | (p1 > 1)){
throw("p1 must be in the [0,1] interval!\n");
}
else if(missing(sd0)){
throw("No sd0 value specified!\n");
}
else if((!is.numeric(sd0)) | (length(sd0) != 1)){
throw("The sd0 parameter must be a numeric vector of length 1!\n");
}
else if( sd0 < 0){
throw("The sd0 parameter must be positive!\n");
}
else if(missing(sd1)){
throw("No sd1 value specified!\n");
}
else if((!is.numeric(sd1)) | (length(sd1) != 1)){
throw("The sd1 parameter must be a numeric vector of length 1!\n");
}
else if( sd1 < 0){
throw("The sd1 parameter must be positive!\n");
}
else if(missing(mean2)){
throw("No mean2 specified!\n");
}
else if((!is.numeric(mean2)) | (length(mean2) != 1)){
throw("The mean2 parameter must be a numeric vector of length 1!\n");
}
else if(missing(sd2)){
throw("No sd2 value specified!\n");
}
else if((!is.numeric(sd2)) | (length(sd2) != 1)){
throw("The sd2 parameter must be a numeric vector of length 1!\n");
}
else if( sd2 < 0){
throw("The sd2 parameter must be positive!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
rnorm.gt.0<-function(mean=NA,sd=NA){
# This is probably the most primitive way to truncate the distribution!
tmp<-rnorm(1,mean=mean,sd=sd);
while( tmp <= 0){
tmp<-rnorm(1,mean=mean,sd=sd);
};
return(tmp);
}
for(site in this$.sites[index]){
setParameterAtSite(this=process,site=site, id="omega", value=sample(
c(rnorm.gt.0(mean=0,sd=sd0),rnorm.gt.0(mean=1,sd=sd1),rnorm.gt.0(mean=mean2,sd=sd2)),
size=1,
replace=FALSE,
prob=c(p0,((1-p0)*p1),((1-p0)*(1-p1)))
));
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="CodonSequence",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
for(pos in seq(along.with=this$.sites)){
if(!is.CodonAlphabet(this$.sites[[pos]]$.alphabet)){
throw("The alphabet attached to site ",pos," is not a codon alphabet!\n");
}
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: Translate
##
###########################################################################/**
#
# @RdocMethod Translate
#
# @title "Translate a CodonSequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A CodonSequence object}
# \item{...}{Not used.}
# }
#
# \value{
# The translation as an AminoAcidSequence object.
# }
#
# \examples{
# # create a CodonSequence object
# s<-CodonSequence(string="ATCTTTCGAATGGGGCCCTCCCGA")
# # get the translation as an AminoAcidSequence object
# as<-Translate(s)
# as
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"Translate",
class="CodonSequence",
function(
this,
...
){
# Create an amino acid sequence of proper length:
that<-AminoAcidSequence(
name=paste("Translation of",this$name),
length=this$length
);
# Setting the states, using the site alphabet to translate codons for greater flexibility.
for (pos in seq(along.with=this$.sites)){
setState(that$.sites[[pos]], translateCodon(this$.sites[[pos]]$alphabet, this$.sites[[pos]]$state) );
}
return(that);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass Process
#
# @title "The Process class"
#
# \description{
#
# This is the class representing a generic process acting on Site and Sequence objects. Process objects can be attached
# to Site objects if the associated Alphabet objects match.
#
# The processes can have site-process-specific parameters.
# The templates for site-process-specific parameters and their default values are stored in the Process objects and
# copied into the Site object when the process is attached. See the documentation of the Site class for more details.
#
# The rate multiplier parameter (id="rate.multiplier") is
# present in the Process class and is inherited by all descendant classes.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the Process object: a character vector of length one.}
# \item{alphabet}{The associated Alphabet object.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @methods
# }
#
# \examples{
# # create a Process object
# p<-Process(name="MyProc",alphabet=AminoAcidAlphabet())
# # check if it's a Process object
# is.Process(p)
# # check object consistency
# checkConsistency(p)
# # set process name
# p$name<-"Ppppproccc"
# # get process name
# p$name
# # get unique process identifier
# p$id
# # get the list of site specific paramters and paramter IDs
# p$siteSpecificParamList
# p$siteSpecificParamIds
# # get Process object summary
# summary(p)
# # clone process object
# pp<-clone(p)
# # test object identity
# p == p
# p == pp
# # create a site object
# s<-Site(alphabet=AminoAcidAlphabet())
# # attach process to Site object
# attachProcess(s,p)
# # get events at specified site
# getEventsAtSite(p,s) # empty list
# # detach process via virtual field
# s$processes<-list()
# # attach processes via virtual field
# s$processes<-list(p,pp)
# # set the value of the rate multiplier for Site s
# setParameterAtSite(p,s,id="rate.multiplier",value=2)
# # get the value of the rate multiplier for Site s
# getParameterAtSite(p,s,id="rate.multiplier")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setConstructorS3(
"Process",
function(
name=NA,
alphabet=NA,
...
){
this<-extend(
PSRoot(),
"Process",
.name=NA,
.id=NA,
.alphabet=NA,
.site.specific.param.list=list(),
.event.template=NA,
.write.protected=FALSE,
.is.process=TRUE
);
.addSiteSpecificParameter(
this,
id="rate.multiplier",
name="Rate multiplier",
value=as.double(1),
type="numeric"
);
STATIC<-TRUE;
if(!missing(alphabet)){
this$alphabet<-alphabet;
STATIC<-FALSE;
}
if (!missing(name)){
this$name<-name;
STATIC<-FALSE;
} else {
this$name<-"Anonymous";
}
if(!STATIC) {
this$.event.template<-Event(process=this);
}
this;
},
enforceRCC=TRUE
);
##
## Method: is.Process
##
###########################################################################/**
#
# @RdocDefault is.Process
#
# @title "Check if an object is an instance of the Process class"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
# \examples{
# # create some objects
# a<-Site();
# p<-Process()
# # check if they inherit from Process
# is.Process(a)
# is.Process(p)
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"is.Process",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.process)){return(TRUE)}
if ( inherits(this, "Process")) {
this$.is.process<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="Process",
function(
this,
...
){
if(is.null(this$.alphabet)) {
throw("Process alphabet is NULL!\n");
}
else if(is.null(this$.name)) {
throw("Process name is NULL!\n");
}
if(is.null(this$.site.specific.param.list)) {
throw("Site specific parameter list is NULL!\n");
}
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# Do not reset alphabet for substirution processes
# as that would wipe out the rates:
if (!is.na(this$alphabet) & !is.GeneralSubstitution(this)) {
this$alphabet<-this$alphabet;
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
.checkSiteSpecificParamList(this,plist=this$.site.specific.param.list);
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkSiteSpecificParamList
##
setMethodS3(
".checkSiteSpecificParamList",
class="Process",
function(
this,
plist,
...
){
if (missing(plist)) {
throw("No list given!\n");
}
if(!is.list(plist)) {
throw("Site specific parameter list is invalid!\n");
} else {
for (p in plist) {
if (!setequal(names(p),c("name","value","type"))) {
throw("Process-site specific parameter list inconsistent!\n");
}
else {
if (length(p$name) == 0 | !is.character(p$name)) {
throw("Site specific process parameter name invalid!\n");
}
else if (length(p$type) == 0 | !is.character(p$type)) {
throw("Site specific process parameter type invalid!\n");
}
else if (length(intersect(class(p$value),p$type)) == 0 ) {
throw(paste("The site specific parameter \"",p$name,"\" supposed to be \"",p$type,"\", but it is something else!\n",sep=""));
}
}
}
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: ==.Process
##
###########################################################################/**
#
# @RdocMethod ==
# \alias{!=.Process}
#
# @title "Check whether the two supplied Process objects are identical"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{e1}{A Process object.}
# \item{e2}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE;
# }
#
# \examples{
# # create some Process objects
# p1<-Process()
# p2<-clone(p1)
# # check object equality
# p1 == p1
# p1 == p2
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"==",
class="Process",
function(
e1,
e2,
...
){
equals(e1, e2);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: !=.Process
##
setMethodS3(
"!=",
class="Process",
function(
e1,
e2,
...
){
!equals(e1, e2);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .addSiteSpecificParameter
##
setMethodS3(
".addSiteSpecificParameter",
class="Process",
function(
this,
id,
name,
value,
type,
...
){
if (missing(id)) {throw("No id given!\n")}
else if (missing(name)) {throw("No name given!\n")}
else if (missing(value)) {throw("No value given!\n")}
else if (length( intersect(class(value),type) ) == 0 ) {
throw("The specified default value is not of the correct type!\n");
}
id<-as.character(id);
this$.site.specific.param.list[[id]]<-list(
"name"=name,
"value"=value,
"type"=type
);
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getId
##
###########################################################################/**
#
# @RdocMethod getId
#
# @title "Get the unique identifier of a Process object"
#
# \description{
# @get "title".
# The unique identifier is the concatenation of the class, the object name as returned by getName() and the object hash
# as returned by hashCode().
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a Process object
# p<-Process()
# # get unique id
# getId(p)
# # get unique id via virtual field
# p$id
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getId",
class="Process",
function(
this,
...
){
this$.id;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .setId
##
setMethodS3(
".setId",
class="Process",
function(
this,
...
){
this.class<-class(this)[1];
this$.id<-paste(this.class,this$.name,hashCode(this),sep=":");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setId
##
###########################################################################/**
#
# @RdocMethod setId
#
# @title "Forbidden action: setting the unique Process object identifier"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setId",
class="Process",
function(
this,
value,
...
){
throw("Id is generated automatically and it cannot be set!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getName
##
###########################################################################/**
#
# @RdocMethod getName
#
# @title "Get the name of a Process object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# A charcter vector of length one.
# }
#
# \examples{
# # create a Process object
# p<-Process()
# # get object name
# getName(p)
# # get name via virtual field
# p$name
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getName",
class="Process",
function(
this,
...
){
this$.name;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setName
##
###########################################################################/**
#
# @RdocMethod setName
#
# @title "Set the name of a Process object"
#
# \description{
# @get "title".
#
# This method also updates the unique identifier of the Process object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{new.name}{A character vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns the new name (invisible).
# }
#
# \examples{
# # create object
# p<-Process()
# # get name
# p$name
# # set new name
# getName(p)
# # get name and id
# p$name
# p$id
# # set new name via virtual field
# p$name<-"Procey"
# p$name
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setName",
class="Process",
function(
this,
new.name,
...
){
.checkWriteProtection(this);
this$.name<-as.character(new.name);
.setId(this);
invisible(new.name);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSiteSpecificParamList
##
###########################################################################/**
#
# @RdocMethod getSiteSpecificParamList
#
# @title "Get the list of site specific parameters of a Process object"
#
# \description{
# @get "title".
# Every site specific parameter is a list storing the name, the identifier and the type of the given parameter.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of site specific parameters.
# }
#
# \examples{
# # create a process object
# p<-Process()
# # get the list of site specific parameters
# getSiteSpecificParamList(p)
# # get it via virtual field
# p$siteSpecificParamList
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSiteSpecificParamList",
class="Process",
function(
this,
...
){
this$.site.specific.param.list;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setSiteSpecificParamList
##
###########################################################################/**
#
# @RdocMethod setSiteSpecificParamList
#
# @title "Forbidden action: setting the site specific paramter list for a Process object"
#
# \description{
# @get "title".
# Use .addSiteSpecificParameter to add new site specific paramters when implementing new processes.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setSiteSpecificParamList",
class="Process",
function(
this,
value,
...
){
throw("You should not set the siteSpecificParamList directly!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSiteSpecificParamIds
##
###########################################################################/**
#
# @RdocMethod getSiteSpecificParamIds
#
# @title "Get the site specific paramter identifiers from a Process object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# A charcter vector.
# }
#
# \examples{
# # create process object
# p<-Process()
# # get site specific parameter identifiers
# getSiteSpecificParamIds(p)
# # via virtual field
# p$siteSpecificParamIds
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSiteSpecificParamIds",
class="Process",
function(
this,
...
){
names(this$.site.specific.param.list);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setSiteSpecificParamIds
##
###########################################################################/**
#
# @RdocMethod setSiteSpecificParamIds
#
# @title "Forbidden action: setting the paramter identifiers of the site specific paramters from a Process object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setSiteSpecificParamIds",
class="Process",
function(
this,
value,
...
){
throw("You should not set the siteSpecificParamIds directly!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAlphabet
##
###########################################################################/**
#
# @RdocMethod getAlphabet
#
# @title "Get the Alphabet object associated with a given Process object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# An Alphabet object.
# }
#
# \examples{
# # create a process object
# p<-Process(alphabet=NucleotideAlphabet())
# # get associated Alphabet object
# getAlphabet(p)
# # via virtual field
# p$alphabet
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAlphabet",
class="Process",
function(
this,
...
){
this$.alphabet;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setAlphabet
##
###########################################################################/**
#
# @RdocMethod setAlphabet
#
# @title "Assotiate an Alphabet object with a Process object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{new.alphabet}{A valid Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# The Alphabet object (invisible).
# }
#
# \examples{
# # create objects
# a<-AminoAcidAlphabet()
# p<-Process()
# # assotiate p with Alphabet object a
# setAlphabet(p,a)
# p$alphabet
# # assotiate p with a new NucleotideAlphabet via virtual field
# p$alphabet<-NucleotideAlphabet()
# p$alphabet
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setAlphabet",
class="Process",
function(
this,
new.alphabet,
...
){
.checkWriteProtection(this);
if (!is.Alphabet(new.alphabet)) {throw("The alphabet object is invalid!\n")}
else {
this$.alphabet<-new.alphabet;
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventsAtSite
##
###########################################################################/**
#
# @RdocMethod getEventsAtSite
#
# @title "Generate the list of active Event objects given a Site object"
#
# \description{
# @get "title".
# The Process object must be attached to the specified Site object.
#
# This method is crucial for the simulations. For the Process class it returns an empty list.
# Descendant classes should implement meaningful getEventsAtSite methods.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{site}{A valid Site object.}
# \item{position}{The position of the site in the enclosing Sequence object (if any).}
# \item{...}{Not used.}
# }
#
# \value{
# An empty list.
# }
#
# \examples{
# # create objects
# a<-NucleotideAlphabet()
# p<-Process(alphabet=a)
# s<-Site(alphabet=a)
# # attach Process p to Site s
# s$processes<-list(p)
# # get active Event objects (empty list)
# getEventsAtSite(p,s)
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEventsAtSite",
class="Process",
function(
this,
site,
position,
...
){
# Returns a list of event objects;
#e1<-Event(name="A->T",rate=0.2,process=this);
#e2<-clone(e1);
#e1$name<-"Insertion";
#list(e1,e2);
list();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getWriteProtected
##
###########################################################################/**
#
# @RdocMethod getWriteProtected
#
# @title "Check if the object is write protected"
#
# \description{
# @get "title".
# Write protected objects cannot be modified through get/set methods and virtual fields.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
# \examples{
#
# # create an object
# o<-Process()
# # toggle write protection
# o$writeProtected<-TRUE
# # check if it's write protected
# getWriteProtected(o)
# # check write protection via virtual field
# o$writeProtected
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getWriteProtected",
class="Process",
function(
this,
...
){
this$.write.protected;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setWriteProtected
##
###########################################################################/**
#
# @RdocMethod setWriteProtected
#
# @title "Set the write protection field for an object"
#
# \description{
# @get "title".
# Write protected objects cannot be modified through get/set methods and virtual fields.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{value}{A logical vector of size one.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE or FALSE.
# }
#
# \examples{
#
# # create an object
# o<-Process()
# # toggle write protection
# setWriteProtected(o,TRUE)
# # check write protection
# o$writeProtected
# # set write protection via virtual field
# o$writeProtected<-FALSE
# o$writeProtected
#
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setWriteProtected",
class="Process",
function(
this,
value,
...
){
if(!is.logical(value)) {throw("The new value must be logical!\n")}
else {
this$.write.protected<-value;
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: hasUndefinedRate
##
###########################################################################/**
#
# @RdocMethod hasUndefinedRate
#
# @title "Check if the Process object has undefined rate parameters"
#
# \description{
# @get "title".
#
# For the instances of the Process class this method always returns FALSE.
# Descendant classes should implement more meaningful methods.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# FALSE
# }
#
# \examples{
# # create object
# p<-Process()
# # check if has undefined rates
# hasUndefinedRate(p) # return FALSE
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"hasUndefinedRate",
class="Process",
function(
this,
...
){
return(FALSE);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkWriteProtection
##
setMethodS3(
".checkWriteProtection",
class="Process",
function(
this,
value,
...
){
if(exists(x="PSIM_FAST")){
return(FALSE);
}
if(this$writeProtected) {throw("Cannot set value because the object is write protected!\n")}
else {return(FALSE)}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: clone
##
###########################################################################/**
#
# @RdocMethod clone
#
# @title "Clone a process object"
#
# \description{
# @get "title".
# Write protection is set to FALSE for the new Process object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# A Process object.
# }
#
# \examples{
# # create a process object
# p<-Process()
# # clone process object
# pp<-clone(p)
# # check identity
# p == pp
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"clone",
class="Process",
function(
this,
...
){
tmp<-clone.Object(this);
if(tmp$writeProtected){
tmp$writeProtected<-FALSE;
}
# Reassingning name to
# force Id update.
tmp$name<-tmp$name;
tmp;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: as.character.Process
##
###########################################################################/**
#
# @RdocMethod as.character
#
# @title "Get the character representation of a Process object"
#
# \description{
# @get "title".
# The string returned is the unique Process object identifier (class name + process name + object hash).
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A Process object}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
#
# # create a Process object
# p<-Process()
# # get charatcer representation
# x<-as.character(p)
# print(x)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"as.character",
class="Process",
function(
x,
...
){
x$id;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .addSummaryAlphabet
##
setMethodS3(
".addSummaryAlphabet",
class="Process",
function(
this,
...
){
if(!is.na(this$alphabet)) {
alphabet_symbols<-paste(this$alphabet$symbols,collapse=" ");
this$.summary$"Alphabet"<-paste("\n"," Type: ",this$alphabet$type,"\n"," Symbols: ", alphabet_symbols,sep="");
} else {
this$.summary$"Alphabet"<-NA
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .addSummaryNameId
##
setMethodS3(
".addSummaryNameId",
class="Process",
function(
this,
...
){
if(is.null(this$.summary$"Name")){
this$.summary$"Name"<-this$name;
}
if(is.null(this$.summary$"Id")){
this$.summary$"Id"<-this$id;
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.Process
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-NucleotideAlphabet()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="Process",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
# Skip the alphabet for InDel processes
if(!is.GeneralInDel(this)){
.addSummaryAlphabet(this);
}
tmp<-character();
param_list<-this$siteSpecificParamList;
counter<-0;
for (id in names(param_list)) {
param<-param_list[[id]];
tmp<-paste(tmp,
"\n Id: ",id,
"\n Name: ",param$name,
"\n Type: ",param$type,
"\n Default value: ",param$value,
sep=""
);
counter<-counter+1;
if ( counter < length(param_list) ){
tmp<-paste(tmp,"\n");
}
}
header<-paste("Site specific parameters (",length(param_list),")",sep="");
this$.summary[[header]]<-tmp;
if(getWriteProtected(this)) {
this$.summary$"Write protected"<-TRUE;
}
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: hasSiteSpecificParameter
##
###########################################################################/**
#
# @RdocMethod hasSiteSpecificParameter
#
# @title "Check if a Process object has the site-process specific parameter with the given id"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{id}{The identifier of the site-process specific parameter of interest.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create a process object
# p<-Process()
# # check whether it has the "rate.multiplier" site-process specific paramter
# hasSiteSpecificParameter(p,"rate.multiplier"); # TRUE
# # check whether it has the "omega" site-process specific paramter
# hasSiteSpecificParameter(p,"omega"); # FALSE
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"hasSiteSpecificParameter",
class="Process",
function(
this,
id,
...
){
if (missing(id)) {throw("Parameter identifier is missing!\n")}
else if ( length (intersect((as.vector(this$siteSpecificParamIds) == id),TRUE) ) == 0 ) {
return(FALSE);
} else {
return(TRUE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getParameterAtSite
##
###########################################################################/**
#
# @RdocMethod getParameterAtSite
#
# @title "Get the value of a site-process specific paramter from a Site object attached to a Process object"
#
# \description{
# @get "title".
# The Process object must be attached to the Site object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{site}{A Site object.}
# \item{id}{The identifier of the site-process specific parameter.}
# \item{...}{Not used.}
# }
#
# \value{
# The site-process specific parameter, which is a list containing the following keys: id, name, value, type.
# }
#
# \examples{
# # create a Site and a Process object
# a<-Alphabet()
# s<-Site(alphabet=a)
# p<-Process(alphabet=a)
# # attach the process
# attachProcess(s,p)
# # get the value of the rate multiplier
# getParameterAtSite(p,s,"rate.multiplier")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getParameterAtSite",
class="Process",
function(
this,
site,
id,
...
){
if (missing(id)) {throw("Parameter identifier is missing!\n")}
if (.checkTriplett(this,site,id)){
id<-as.character(id);
list (
id=id,
name=site$.processes[[getId(this)]]$site.params[[id]]$name,
value=site$.processes[[getId(this)]]$site.params[[id]]$value,
type=site$.processes[[getId(this)]]$site.params[[id]]$type
);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .getParameterAtSiteFast
##
setMethodS3(
".getParameterAtSiteFast",
class="Process",
function(
this,
site,
id,
...
){
site$.processes[[this$.id]]$site.params[[as.character(id)]]$value;
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setParameterAtSite
##
###########################################################################/**
#
# @RdocMethod setParameterAtSite
# \alias{setParameterAtSite.FastFieldDeletor}
# @title "Set the value of a site-process specific paramter in a Site object attached to a Process object"
#
# \description{
# @get "title".
# The Process object must be attached to the Site object. The new value must be compatible with the type
# of the site-process specific parameter.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Process object.}
# \item{site}{A Site object.}
# \item{id}{The identifier of the site-process specific parameter.}
# \item{value}{The new value for the parameter.}
# \item{...}{Not used.}
# }
#
# \value{
# The site-process specific parameter, which is a list containing the following keys: id, name, value, type.
# }
#
# \examples{
# # create a Site and a Process object
# a<-BinaryAlphabet()
# s<-Site(alphabet=a)
# p<-Process(alphabet=a)
# # attach the process
# attachProcess(s,p)
# # set the value of the rate multiplier
# setParameterAtSite(p,s,"rate.multiplier",2)
# # get the value of the rate multiplier
# getParameterAtSite(p,s,"rate.multiplier")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setParameterAtSite",
class="Process",
function(
this,
site,
id,
value,
...
){
if(!exists(x="PSIM_FAST")){
if (missing(id)) {throw("Parameter identifier is missing!\n")};
}
id<-as.character(id);
if (.checkTriplett(this,site,id)){
type<-site$.processes[[this$id]]$site.params[[id]]$type;
if(!exists(x="PSIM_FAST")){
if (length(intersect(class(value),type)) == 0 ) {throw("The new value is of wrong type!\n")}
}
site$.processes[[this$id]]$site.params[[id]]$value<-value;
}
site$.total.rate<-NA;
if(!is.na(site$.sequence)){
site$.sequence$.cumulative.rate.flag<-TRUE;
}
invisible(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkTriplett
##
setMethodS3(
".checkTriplett",
class="Process",
function(
this,
site,
id,
...
){
if(exists(x="PSIM_FAST")){ return(TRUE) }
if (!is.Site(site)) {throw ("Site object not valid!\n")}
else if (!hasSiteSpecificParameter(this,id)) {
throw(paste("The process",this$id,"has no site specific paramter with id:",id,"!\n",sep=" "));
}
else if (!isAttached(site,this)) {throw("Process is not attached to site!\n")} else {
return(TRUE);
}
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass QMatrix
#
# @title "The QMatrix class"
#
# \description{
# This is the class representing rate matrices. The QMatrix objects store two rate matrices: one contains
# the rates provided by the user (unscaled rate matrix), the other matrix (scaled rate matrix) is rescaled so the
# expected number of subsitutions per unit time is equal to one when the process is at equlibrium.
# The scaled rate matrices, along with the site-process-specific rate multiplier
# parameters define the rates of the Event objects generated by the associated GeneralSubstitution objects.
#
# The QMatrix objects have a bidirectonal relationship with the GeneralSubstitution object as they store a reference
# to the associated process objects. QMatrix objects do not have a write-protection field, but they use the one
# from the associated GeneralSubstitution object.
#
# Usually there is no need to interact with the QMatrix objects directly, so this class
# is mainly used internally.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the QMatrix object (a character vector of length one).}
# \item{alphabet}{An Alphabet object.}
# \item{rate.list}{A list of unscaled event rates and the associated event names. It will be passed to the \code{setRateList.QMatrix} method.}
# \item{process}{A GeneralSubstitution object to be associated with the QMatrix object.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a QMatrix object by providing an Alphabet object and rates
# m<-QMatrix(name="Susie Q", alphabet=BinaryAlphabet(), rate.list=list("1->0"=2,"0->1"=3))
# # get object summary
# summary(m)
# # create a GeneralSubstitution object by
# # providing an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=3))
# # get the QMatrix object from p
# m<-p$QMatrix
# # get various object properties
# m
# is.QMatrix(m)
# m$name
# m$id
# m$alphabet
# # get the associated process
# m$process
# # get the unscaled rate of "0->1"
# getRate(m,"0->1")
# # get the scaled rate of "0->1"
# getEventRate(m,"0->1")
# # get the list of unscaled rates
# m$rateList
# # get unscaled rate matrix
# m$matrix
# # get scaled rate matrix
# m$scaledMatrix
# }
#
# @author
#
# \seealso{
# GeneralSubstitution Alphabet Process
# }
#
#*/###########################################################################
setConstructorS3(
"QMatrix",
function(
name="Anonymous",
alphabet=NA,
rate.list=NA,
process=NA,
...
) {
this<-PSRoot();
this<-extend(
this,
"QMatrix",
.name=NA,
.alphabet=NA,
.rate.matrix=NA,
.orig.matrix=NA,
.norm.const=NA,
.process=NA,
.is.q.matrix=TRUE
);
this$name<-name;
if(!missing(process)){
this$process<-process;
}
if(!missing(alphabet)){
this$alphabet<-alphabet;
}
if(!missing(rate.list)){
if(missing(alphabet)){
throw("Cannot set rates because the alphabet is not specified!\n")
}
this$rateList<-rate.list;
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: .buildRateMatrix
##
setMethodS3(
".buildRateMatrix",
class="QMatrix",
function(
this,
...
){
size<-this$alphabet$size;
symbols<-this$alphabet$symbols;
# Setting the dimension names
# for the original rates matrix:
if(!isEmpty(this$.alphabet)){
this$.orig.matrix<-matrix(nrow=size,ncol=size);
colnames(this$.orig.matrix)<-symbols;
rownames(this$.orig.matrix)<-symbols;
}
# Copy to the scaled matrix:
this$.rate.matrix<-this$.orig.matrix;
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{check.process}{Check the associated process object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="QMatrix",
function(
this,
check.process=TRUE,
...
){
if(is.Process(this$.process)){
wp<-this$.process$.write.protected;
if (wp) {
# Cannot use virtual field here because of
# some obscure errror:
this$.process$.write.protected<-FALSE;
}
}
may.fail<-function(this) {
# Reassing name:
this$name<-this$name;
# Do not reassign alphabet as that will wipe out the rates!
if(!is.na(this$.alphabet) & !is.Alphabet(this$.alphabet)){
throw("QMatrix alphabet is invalid!\n");
}
# Check if the original rate matrix is a matrix or NA.
if(!is.matrix(this$.orig.matrix) & !all(is.na(this$.orig.matrix))){
throw("The original rates matrix is invalid!\n");
}
# Check original rates matrix size:
else if(!all(dim(this$.orig.matix) != c(this$.alphabet$.size, this$.alphabet$.size))) {
throw("The original rates matrix is of wrong size!");
}
# Check if the rescaled rate matrix is a matrix or NA.
if(!is.matrix(this$.rate.matrix) & !all(is.na(this$.rate.matrix))){
throw("The rescaled rates matrix is invalid!\n");
}
# Check rescaled rates matrix size:
else if(!all(dim(this$.rates.matix) != c(this$.alphabet$.size, this$.alphabet$.size))) {
throw("The original rates matrix is of wrong size!");
}
# Flag for not having NA-as in the matrices.
COMPLETE<-TRUE;
if(is.matrix(this$.orig.matrix) ){
if(any(is.na(this$.orig.matrix))){
warning("Some rates are undefined!\n");
COMPLETE<-FALSE;
}
# Watch out for the operator precedence here!
else if ( (!all(is.numeric(this$.orig.matrix))) & (!all(is.na(this$.orig.matrix))) ){
print(this$.orig.matrix)
throw("The original rates matrix has non-numeric elements!\n");
}
}
if(is.matrix(this$.orig.matrix) ){
if( any(is.na(this$.orig.matrix)) & COMPLETE ){
COMPLETE<-FALSE;
throw("The original rates matrix is complete, but the rescaled matrix has undefined elements!\n");
}
# Watch out for the operator precedence here!
else if ( (!all(is.numeric(this$.orig.matrix)) & (!all(is.na(this$.orig.matrix)))) ){
throw("The original rates matrix has non-numeric elements!\n");
}
}
# Check the normalizing constant:
if( length(this$.norm.const) != 1 | (!is.na(this$.norm.const) & !is.numeric(this$.norm.const)) ){
throw("Normalizing constant is invalid!\n");
}
# Check the normalization:
if(is.matrix(this$.orig.matrix) & is.matrix(this$.rate.matrix) & COMPLETE ){
if(!PSRoot$my.all.equal(this$.rate.matrix, (this$.norm.const * this$.orig.matrix)) ){
throw("The scaled matrix is inconsistent with the original matrix and the normalizing constant!\n");
}
}
# Check the process:
if(check.process==TRUE){
if(is.Process(this$.process)){
# Check for alphabet compatibility:
if(this$.alphabet != this$.process$alphabet){
throw("Process/QMatrix alphabet mismatch!\n");
}
# Check if the parent process QMatrix is this object:
if(!equals(this$.process$.q.matrix, this) ){
throw("Parent process QMatrix is not identical with self!\n");
}
}
else if(!is.na(this$.process)){
throw("Process entry is invalid!\n");
}
}
}
tryCatch(may.fail(this),finally={if(is.Process(this$.process)){this$.process$.write.protected<-wp}});
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .callRateRescaling
##
setMethodS3(
".callRateRescaling",
class="QMatrix",
function(
this,
guess.equ=TRUE,
...
){
# Usually called when the rate matrix chenges.
# If the Q matrix has a parent process with a valid equilibrium distribution:
if(is.Process(this$.process) & !any(is.na(as.vector(this$.orig.matrix))) ){
if(guess.equ){
# Try to guess the new equlibrium distribution:
if(!.setEquDistFromGuess(this$.process)){
# Fill with NA-s if failed with guessing:
.initEquDist(this$.process);
}
}
# Rescale if the equilibrium distribution was succesfully set:
if(all(!is.na(this$.process$equDist))){
rescaleQMatrix(this$.process);
}
}
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getName
##
###########################################################################/**
#
# @RdocMethod getName
#
# @title "Get the name of a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{...}{Not used.}
# }
#
# \value{
# A charcter vector of length one.
# }
#
# \examples{
# # create a QMatrix object
# m<-QMatrix()
# # set/get name
# setName(m,"Susie Q")
# getName(m)
# # set/get name via virtual field
# m$name<-"Q"
# m$name
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getName",
class="QMatrix",
function(
this,
...
){
this$.name;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setName
##
###########################################################################/**
#
# @RdocMethod setName
#
# @title "Set the name of a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{value}{A character vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new object name.
# }
#
# \examples{
# # create a QMatrix object
# m<-QMatrix()
# # set/get name
# setName(m,"Susie Q")
# getName(m)
# # set/get name via virtual field
# m$name<-"Q"
# m$name
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setName",
class="QMatrix",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(missing(value)){
throw("No new value provided!\n");
}
else{
value<-as.character(value);
if(stringLength(value) == 0){
throw("Cannot set empty name!");
} else {
this$.name<-value;
}
}
return(this$.name);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getProcess
##
###########################################################################/**
#
# @RdocMethod getProcess
#
# @title "Get the process object associated with a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{...}{Not used.}
# }
#
# \value{
# A process object, most likely one which inherits from GeneralSubstitution.
# }
#
# \examples{
# # Create a GeneralSubstitution object
# p<-GeneralSubstitution(alphabet=BinaryAlphabet())
# p
# # get the associated QMatrix object from p
# m<-p$qMatrix
# summary(m)
# # get the associated process from m
# m$process
# # clone p
# pp<-clone(p)
# # assotiate m with pp
# pp$qMatrix<-m
# # assotiate pp with m
# m$process<-pp
# m$process
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getProcess",
class="QMatrix",
function(
this,
...
){
this$.process;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setProcess
##
###########################################################################/**
#
# @RdocMethod setProcess
#
# @title "Assotiate a process object with a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{value}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# The Process object.
# }
#
# \examples{
# # Create a GeneralSubstitution object
# p<-GeneralSubstitution(alphabet=BinaryAlphabet())
# p
# # get the associated QMatrix object from p
# m<-p$qMatrix
# summary(m)
# # get the associated process from m
# m$process
# # clone p
# pp<-clone(p)
# # assotiate m with pp
# pp$qMatrix<-m
# # assotiate pp with m
# m$process<-pp
# m$process
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setProcess",
class="QMatrix",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(missing(value)){
throw("No new value provided!\n");
}
else if (!is.Process(value)){
throw("Process object invalid!\n");
}
else {
this$.process<-value;
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAlphabet
##
###########################################################################/**
#
# @RdocMethod getAlphabet
#
# @title "Get the Alphabet object associated with a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{...}{Not used.}
# }
#
# \value{
# An Alphabet object.
# }
#
# \examples{
# # create a QMatrix object
# m<-QMatrix()
# # set the alphabet
# setAlphabet(m,NucleotideAlphabet())
# # get the alphabet
# getAlphabet(m)
# # set alphabet via virtual field
# m$alphabet<-BinaryAlphabet()
# summary(m)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAlphabet",
class="QMatrix",
function(
this,
...
){
this$.alphabet;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setAlphabet
##
###########################################################################/**
#
# @RdocMethod setAlphabet
#
# @title "Set the Alphabet object for a QMatrix object"
#
# \description{
# @get "title".
#
# This method rebuilds the scaled and unscaled rate matrices and so sets all rates to NA.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{value}{An Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# The Alphabet object.
# }
#
# \examples{
# # create a QMatrix object
# m<-QMatrix()
# # set the alphabet
# setAlphabet(m,NucleotideAlphabet())
# # get the alphabet
# getAlphabet(m)
# # set alphabet via virtual field
# m$alphabet<-BinaryAlphabet()
# summary(m)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setAlphabet",
class="QMatrix",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)){
throw("No new value provided!\n");
}
else if(!is.Alphabet(value)) {
throw("Alphabet object invalid!\n");
}
else if(is.Process(this$.process)){
if(value != this$.process$alphabet){
throw("The new alphabet should match with the one from the subsitution process!\n");
}
}
if(is.matrix(this$.rate.matrix)){
warning("Be aware that setting a new alphabet wipes out completely the rate matrix!\n");
}
}
this$.alphabet<-value;
.buildRateMatrix(this);
return(this$.alphabet);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .nameToDim
##
setMethodS3(
".nameToDim",
class="QMatrix",
function(
this,
name,
...
){
# split the name
substitution<-rbind(strsplit(name,split="->",fixed=TRUE)[[1]]);
if(length(substitution) != 2 ) {
throw("Substitution event name was invalid!");
}
# Check if symbols are valid:
if(!hasSymbols(this$.alphabet, substitution)){
throw("All symbols must be in the alphabet!\n");
}
# Return a vector with the DIMNAMES:
colnames(substitution)<-c("from","to");
rownames(substitution)<-c("Substitution");
substitution;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .nameToDimFast
##
setMethodS3(
".nameToDimFast",
class="QMatrix",
function(
this,
name,
...
){
substitution<-rbind(strsplit(name,split="->",fixed=TRUE)[[1]]);
colnames(substitution)<-c("from","to");
rownames(substitution)<-c("Substitution");
substitution;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .dimToName
##
setMethodS3(
".dimToName",
class="QMatrix",
function(
this,
dim,
...
){
paste(dim,collapse="->");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventRate
##
###########################################################################/**
#
# @RdocMethod getEventRate
#
# @title "Get the unscaled rate of an event from a QMatrix object"
#
# \description{
# @get "title".
#
# This method return the element corresponding to a given event from the scaled rate matrix stored in a QMatrix object.
# The event can be specified by the inital and target states ("from" and "to" arguments), or by the
# event name ("from->to"). The event name takes precedence over the "from" and "to" arguments.
#
# This method returns NA if the resacling of the rates was not performed.
# The scaling is performed by the \code{rescaleQMatrix.GeneralSubstitution} method.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{name}{The name of the event.}
# \item{from}{The initial state.}
# \item{to}{Target state.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
# \examples{
# # create a QMatrix object
# # provide an Alphabet object and the rates
# m<-QMatrix(alphabet=BinaryAlphabet(), rate.list=list("0->1"=1,"1->0"=1))
# # get the unscaled rate of "0->1" by name
# getEventRate(m,"0->1") # retruns NA
# # get the unscaled rate of "0->1" by states
# getEventRate(m,from="0",to="1") # returns NA
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEventRate",
class="QMatrix",
function(
this,
name=NA,
from=NA,
to=NA,
...
){
# Event specified by name:
if(!missing(name) & missing(from) & missing(to)){
# convert to dimnames
tmp<-.nameToDim(this, name);
# Return the rate from the rescaled matrix:
return(this$.rate.matrix[tmp[1],tmp[2]]);
}
# Event specified by from= and to=
else if(missing(name) & !missing(from) & !missing(to)){
# Check symbols:
if(!hasSymbols(this$.alphabet, c(from,to))){
throw("All symbols must be in the alphabet!\n")
}
else{
# Get the rate from the rescaled matrix:
return(this$.rate.matrix[as.character(from),as.character(to)]);
}
}
else {
throw("The substitution should be specified by name or by the \"from\" and \"to\" arguments!\n");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .getEventRateFast
##
setMethodS3(
".getEventRateFast",
class="QMatrix",
function(
this,
name=NA,
...
){
# convert to dimnames
tmp<-.nameToDimFast(this, name);
# Return the rate from the rescaled matrix:
return(this$.rate.matrix[tmp[1],tmp[2]]);
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRate
##
###########################################################################/**
#
# @RdocMethod getRate
#
# @title "Get an unscaled rate of an event from a QMatrix object"
#
# \description{
# @get "title".
#
# This method gets the element corresponding to a given event form the \emph{unscaled} rate matrix.
# a given event. The event can be specified by the inital and target states ("from" and "to" arguments), or by the
# event name ("from->to"). The event name takes precedence over the "from" and "to" arguments.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{name}{The name of the event.}
# \item{from}{The initial state.}
# \item{to}{Target state.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
# \examples{
# # create a QMatrix object
# # provide an Alphabet object and the rates
# m<-QMatrix(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # get the unscaled rate of "0->1" by name
# getRate(m,"0->1")
# # get the unscaled rate of "0->1" by states
# getRate(m,from="0",to="1")
# }
#
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRate",
class="QMatrix",
function(
this,
name=NA,
from=NA,
to=NA,
...
){
# Event specified by name:
if(!missing(name) & missing(from) & missing(to)){
# Convert to dimnames:
tmp<-.nameToDim(this, name);
# return unscaled rate:
return(this$.orig.matrix[tmp[1],tmp[2]]);
}
# Event specified by from= and to=:
else if(missing(name) & !missing(from) & !missing(to)){
# check symbols:
if(!hasSymbols(this$.alphabet, c(from,to))){
throw("All symbols must be in the alphabet!\n")
}
else{
# return unscaled rate:
return(this$.orig.matrix[as.character(from),as.character(to)]);
}
}
else {
throw("The substitution should be specified by name or by the \"from\" and \"to\" arguments!\n");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRate
##
###########################################################################/**
#
# @RdocMethod setRate
#
# @title "Set an unscaled rate in a QMatrix object"
#
# \description{
# @get "title".
#
# This method sets the element corresponding to a given event in the unscaled rate matrix.
# The event can be specified by the inital and target states ("from" and "to" arguments), or by the
# event name ("from->to"). The event name takes precedence over the "from" and "to" arguments.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{name}{The name of the event.}
# \item{value}{The new value of the rate.}
# \item{from}{The initial state.}
# \item{to}{Target state.}
# \item{scale}{Call rate rescaling.}
# \item{diag}{Calculate diagonal elements.}
# \item{guess.equ}{Guess equilibrium distribution.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
# \examples{
# # create a QMatrix object
# # provide an Alphabet object and the rates
# m<-QMatrix(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # set the unscaled rate by event name
# setRate(m,"0->1",2)
# # get the unscaled rate of "0->1" by name
# getRate(m,"0->1")
# # set the unscaled rate by states
# setRate(m,"0->1",0.5)
# # set the unscaled rate of "0->1" by states
# setRate(m,"0->1",0.5)
# # get the unscaled rate of "0->1" by states
# getRate(m,from="0",to="1")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRate",
class="QMatrix",
function(
this,
name=NA,
value,
from=NA,
to=NA,
scale=TRUE,
diag=TRUE,
guess.equ=TRUE,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if (isEmpty(this$.alphabet)){
throw("Alphabet is valid but empty, so no rates are defined!\n");
}
else if(missing(value)) {
throw("No new value provided!\n");}
else if(!is.numeric(value)) {
throw("Rate must be numeric!\n");
}
else if (value < 0){
throw("Cannot set negative rate!\n");
}
}
.from<-character();
.to<-character();
# Event specified by name:
if(!missing(name) & missing(from) & missing(to)){
# convert to dimnames:
tmp<-.nameToDim(this, name);
.from<-tmp[1];
.to<-tmp[2];
}
# Event specified by from= and to=:
else if(missing(name) & !missing(from) & !missing(to)){
# check the symbols
if(!hasSymbols(this$.alphabet, c(from,to))){
throw("All symbols must be in the alphabet!\n")
}
else{
.from<-as.character(from);
.to<-as.character(to);
}
}
else {
throw("The substitution should be specified by name or by the \"from\" and \"to\" arguments!\n");
}
# Complain if tried to modify a diagonal element:
if(.from == .to){
throw("Modification of diagonal elements is not allowed!\n");
}
else {
# Set the rate in the original rates matrix:
this$.orig.matrix[.from, .to]<-value;
# Set the new diagonal element in the original rates matrix:
if (diag == TRUE) {
this$.orig.matrix[.from, .from]<-.calculateDiagonal(this, symbol=.from);
}
# Call rate rescaling, this will set the new values
# in the rescaled rates matrix:
if(scale==TRUE){
.callRateRescaling(this,guess.equ);
}
}
return(invisible(value));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateList
##
###########################################################################/**
#
# @RdocMethod getRateList
#
# @title "Get a list of events and their unscaled rates from a QMatrix object"
#
# \description{
# @get "title".
#
# This method returns the list of event rates from the \emph{unscaled} rate matrix.
# The returned list contains the rates associated with the corresponding event names.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A GeneralSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of event rates.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=3))
# # get the QMatrix object from p
# m<-p$QMatrix
# # get the event rates from the unscaled Q matrix
# getRateList(m)
# # get rates from the unscaled rate matrix via virtual field
# m$rateList
# # set rates in the unscaled rate matrix
# setRateList(m, list("0->1"=1,"1->0"=1))
# m$rateList
# # set rates in the unscaled rate matrix via virtual field
# m$rateList<-list("0->1"=3,"1->0"=1);
# m$rateList
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateList",
class="QMatrix",
function(
this,
...
){
# Be gentle and return an empty list if the
# alphabet is empty:
if( isEmpty(this$.alphabet) ){
return(list());
}
else {
# Fill in the rates list:
rates<-list();
for(i in this$.alphabet$symbols){
for(j in this$.alphabet$symbols){
if(i != j){
name<-paste(i,j,sep="->");
rate<-getRate(this, from=i, to=j);
rates[[name]]<-rate;
}
}
}
return(rates);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateList
##
###########################################################################/**
#
# @RdocMethod setRateList
#
# @title "Setting the unscaled rates stored in a QMatrix object"
#
# \description{
# @get "title".
#
# This method set the rates in the \emph{unscaled} Q matrix based on the provided list containing even names
# and the associated rates. The rate must be specified for every event!
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{value}{A list with the events names and the associated rates.}
# \item{...}{Not used.}
# }
#
# \value{
# The QMatrix object (invisible).
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=3))
# # get the QMatrix object from p
# m<-p$QMatrix
# # get the event rates from the unscaled Q matrix
# getRateList(m)
# # get rates from the unscaled rate matrix via virtual field
# m$rateList
# # set rates in the unscaled rate matrix
# setRateList(m, list("0->1"=1,"1->0"=1))
# m$rateList
# # set rates in the unscaled rate matrix via virtual field
# m$rateList<-list("0->1"=3,"1->0"=1);
# m$rateList
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateList",
class="QMatrix",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!is.Alphabet(this$.alphabet)){
throw("Cannot set rates because alphabet is undefined!\n");
}
if(missing(value)) {
throw("No new value provided!\n");}
else if(!is.list(value)) {
throw("The new value must be a list!\n");
} else {
# Check if all of the rates are specified!
expected<-.genExpected(this);
# Check for missing rates:
if(length(tmp<-setdiff(expected,names(value))) != 0 ){
throw("The rate matrix is not specified correctly, the following rates are missing: ",paste(tmp,collapse=" "),"!\n");
}
# Warn the user about the superfluous rates:
if(length(tmp<-setdiff(names(value),expected)) != 0 ){
warning("The following rates were not expected by this process: ",paste(tmp,collapse=" "),", so they were ignored!\n");
# Getting rid of unexpected rates:
value[tmp]<-NULL;
}
# set the rate matrix if all is OK!
for (name in names(value)){
setRate(this,name=name,value=(value[[name]]),scale=FALSE,diag=FALSE);
}
# Set diagonal elements:
for (sym in this$alphabet$symbols){
this$.orig.matrix[sym, sym]<-.calculateDiagonal(this, sym);
}
# Call the parent process object to guess the new equlibrium distribution and rescale
# rates:
.callRateRescaling(this);
}
return(invisible(this))
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .genExpected
##
setMethodS3(
".genExpected",
class="QMatrix",
function(
this,
...
){
expected<-list();
sym<-this$alphabet$symbols;
# Cretae the list of expected rates:
for(i in sym){
for(j in sym){
if(i != j){
expected<-c(expected,paste(i,j,sep="->"));
}
}
}
return(expected);
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .calculateDiagonal
##
setMethodS3(
".calculateDiagonal",
class="QMatrix",
function(
this,
symbol=NA,
...
){
if(!missing(symbol)){
# convert diname to dim:
index<-.symToIndex(this, symbol=symbol);
}
else {
throw("Symbol not specified!\n");
}
# Return -1 * sum of the off-diagonal elements
# from the row specified by the index:
return(-sum((this$.orig.matrix[symbol,])[-index] ));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .symToIndex
##
setMethodS3(
".symToIndex",
class="QMatrix",
function(
this,
symbol=NA,
...
){
if(exists(x="PSIM_FAST")){
return(which(rownames(this$.orig.matrix) == symbol));
}
if(missing(symbol)){
throw("No symbol specified");
} else {
index<-which(rownames(this$.orig.matrix) == symbol);
if(length(index) == 0){
print(symbol);
throw("Symbol not in rate matrix!\n");
}
else if (length(index) > 1){
throw("Rate matrix is inconsistent!\n");
}
return(index);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getMatrix
##
###########################################################################/**
#
# @RdocMethod getMatrix
#
# @title "Get the unscaled rate matrix form a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix object.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=3))
# # get the QMatrix object from p
# m<-p$QMatrix
# # get the unscaled rate matrix from m
# m$matrix
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getMatrix",
class="QMatrix",
function(
this,
...
){
this$.orig.matrix;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setMatrix
##
###########################################################################/**
#
# @RdocMethod setMatrix
#
# @title "Forbidden action: setting the unscaled rate matrix for a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setMatrix",
class="QMatrix",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getScaledMatrix
##
###########################################################################/**
#
# @RdocMethod getScaledMatrix
#
# @title "Get the scaled rate matrix form a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{...}{Not used.}
# }
#
# \value{
# A matrix object.
# }
#
# \examples{
# # create a GeneralSubstitution object
# # provide an Alphabet object and the rates
# p<-GeneralSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=3))
# # get the QMatrix object from p
# m<-p$QMatrix
# # get the scaled rate matrix from m
# m$scaledMatrix
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getScaledMatrix",
class="QMatrix",
function(
this,
...
){
this$.rate.matrix;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setScaledMatrix
##
###########################################################################/**
#
# @RdocMethod setScaledMatrix
#
# @title "Forbidden action: setting the scaled rate matrix for a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setScaledMatrix",
class="QMatrix",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: Scale
##
###########################################################################/**
#
# @RdocMethod Scale
#
# @title "Scale the scaled rate matrix stored in a QMatrix object by the provided factor"
#
# \description{
# @get "title".
#
# This methods sets the scaled rate matrix to \code{unscaled_matrix * constant}.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{constant}{The scaling factor (a numeric vector of length one).}
# \item{...}{Not used.}
# }
#
# \value{
# The QMatrix object (invisible).
# }
#
# \examples{
# # create a QMatrix object
# # , provide Alphabet object and rates
# m<-QMatrix(name="Susie Q", alphabet=BinaryAlphabet(), rate.list=list("1->0"=2,"0->1"=3))
# # get object summary
# summary(m)
# # perform scaling
# Scale(m, 1/0.666)
# # get object summary
# summary(m)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"Scale",
class="QMatrix",
function(
this,
constant=NA,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(constant)){
throw("No scaling constant specified!\n");
}
if(!is.numeric(constant)){
throw("Scaling constant must be numeric!\n");
}
}
# Set the rescaled matrix to the original matrix
# multiplied by the given constant:
this$.rate.matrix<-(this$.orig.matrix * constant);
# store the current rescaling constant:
this$.norm.const<-constant;
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: as.character
##
###########################################################################/**
#
# @RdocMethod as.character
#
# @title "Return the character representation of a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A QMatrix object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a QMatrix object
# m<-QMatrix()
# # get the character representation
# as.character(m)
# # the same, but implicitly
# m
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"as.character",
class="QMatrix",
function(
x,
...
){
x$id
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: print
##
###########################################################################/**
#
# @RdocMethod print
#
# @title "Print the character representation of a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A QMatrix object.}
# \item{...}{Not used.}
# }
#
# \value{
# The character representation of the QMatrix object.
# }
#
# \examples{
# # create a QMatrix object
# m<-QMatrix()
# # print the character representation
# print(m)
# # the same, but implicitly
# m
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"print",
class="QMatrix",
function(
x,
...
){
print.default(x$.orig.matrix);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-QMatrix(alphabet=BinaryAlphabet(), rate.list=list("0->1"=1,"1->0"=3))
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="QMatrix",
function(
object,
...
){
this<-object;
this$.summary$"Name"<-this$name;
this$.summary$"Id"<-this$id;
this$.summary$"Attached to process"<-this$process;
this$.summary$"Unscaled rate matrix"<-paste( "\n\n\t",paste(capture.output(print(this$.orig.matrix)),collapse="\n\t"),"\n",sep="");
this$.summary$"Scaling factor"<-this$.norm.const;
this$.summary$"Scaled rate matrix"<-paste( "\n\n\t",paste(capture.output(print(this$.rate.matrix)),collapse="\n\t"),"\n",sep="");
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## setId
##
###########################################################################/**
#
# @RdocMethod setId
#
# @title "Forbidden action: setting the unique identifier for a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setId",
class="QMatrix",
function(
this,
value,
...
){
throw("Id is generated automatically and it cannot be set!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getId
##
###########################################################################/**
#
# @RdocMethod getId
#
# @title "Get the unique identifier of a QMatrix object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a QMatrix object
# m<-QMatrix()
# # get object id
# getId(m)
# # get object id via virtual field
# m$id
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getId",
class="QMatrix",
function(
this,
...
){
this.class<-class(this)[1];
id<-paste(this.class,this$.name,hashCode(this),sep=":");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getWriteProtected
##
###########################################################################/**
#
# @RdocMethod getWriteProtected
#
# @title "Check if the object is write protected"
#
# \description{
# @get "title".
#
# QMatrix object do not have a write protection flag of their own, but they use the one from the
# associated Process object.
# Write protected objects cannot be modified through get/set methods and virtual fields.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
#
# @author
#
# \seealso{
# getWriteProtected.Process
# }
#
#*/###########################################################################
setMethodS3(
"getWriteProtected",
class="QMatrix",
function(
this,
...
){
# return false if no process is attached:
if(!is.Process(this$.process)) {
return(FALSE);
}
else {
# The flag from the parent process is used!
return(getWriteProtected(this$.process));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: is.QMatrix
##
###########################################################################/**
#
# @RdocDefault is.QMatrix
#
# @title "Check if an object is an instance of the QMatrix class"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create some objects
# m<-QMatrix()
# p<-Process()
# # chek if they inherit from QMatrix
# is.GeneralSubstitution(m)
# is.GeneralSubstitution(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"is.QMatrix",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.process)){return(TRUE)}
if ( inherits(this, "QMatrix")) {
this$.is.q.matrix<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setWriteProtected
##
###########################################################################/**
#
# @RdocMethod setWriteProtected
#
# @title "Set the write protection field for a QMatrix object"
#
# \description{
# @get "title".
#
# QMatrix object do not have a write protection flag of their own, but they use the one from the
# associated Process object.
# Write protected objects cannot be modified through get/set methods and virtual fields.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A QMatrix object.}
# \item{value}{A logical vector of size one.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
#
# @author
#
# \seealso{
# setWriteProtected.Process
# }
#
#*/###########################################################################
setMethodS3(
"setWriteProtected",
class="QMatrix",
function(
this,
value,
...
){
throw("The QMatrix objects use the write protection flags of the enclosing substitution process, modify that (if exists)!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkWriteProtection
##
setMethodS3(
".checkWriteProtection",
class="QMatrix",
function(
this,
...
){
if(!exists(x="PSIM_FAST")){
return(FALSE);
}
if(this$writeProtected) {throw("Cannot set value because the object is write protected!\n")}
else {return(FALSE)}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the file ../COPYING for licensing issues.
##
##########################################################################/**
#
# @RdocClass Sequence
#
# @title "The Sequence class"
#
# \description{
#
# This is the class representing a sequence. The backbone of the Sequence objects are
# lists aggregating Site objects. The class has fields for keeping track of cumulative
# site rates, the sum of all active event rates and methods for performing actions
# on a collection of sites (positions).
#
# The Sequence objects have a field specifying an ancestral object, which can be a Sequence
# object (when the object is obtained through clone() ) or the "Root insertion process" object
# (for newly created objects).
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the Sequence object.}
# \item{string}{A string containing symbols belonging to the associated Alphabet object.
# It can be used to set the initial states of the aggregated Site objects. It also specifies the length of the sequence}
# \item{length}{The length of the sequence. It cannot be used when 'string' is specified.}
# \item{alphabets}{A list of Alphabet objects to be associated with the Site objects.
# The list is recycled in the case it is shorter than the sequence length.}
# \item{processes}{A list of lists of Process objects to be attached
# (recycled if shorter than sequence length). }
# \item{ancestral.obj}{The ancestral object (Sequence or Process).}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a sequence object by
# # providng alphabets, processes and states
# s.one<-Sequence(
# name="Seq",
# string="AATTGGCCTTAAGGCCTTAA",
# alphabets=list(NucleotideAlphabet()),
# processes=list(list(JC69()))
# )
# s.one
# # check if inherits from Sequence
# is.Sequence(s.one)
# # get object summary
# summary(s.one)
# # create a sequence object,
# # specifying length, alphabets
# # and ancestral object
# s<-Sequence(
# name="Seq",
# length=20,
# ancestral.obj=s.one
# )
# # get sequence string
# s$string
# # get the list of site objects
# s$sites
# # get object id
# s$id
# # set and get name
# s$name<-"SeqSeq"
# s$seq
# # get length
# s$length
# # get and set ancestral object
# s$ancestral
# s$ancestral<-Sequence();
# # set alphabets
# setAlphabets(s,list(NucleotideAlphabet()))
# # set states
# # "A"-s in the range 1:10
# setStates(s,"A",1:10)
# # a pattern of "ATGC"-s in the range 11:20
# setStates(s,c("A","T","G","C"),11:20)
# # get states from range 10:12
# getStates(s,10:12)
# # attach a JC69 process to range 1:10
# jc69<-JC69()
# attachProcess(s,jc69,1:10)
# # set the rate multiplier site-process specific parameter for jc69
# setParameterAtSites(s,jc69,"rate.multiplier",2,1:10)
# # get "rate.multiplier" for jc69 from range 1:2
# getParameterAtSites(s, jc69, "rate.multiplier",1:2)
# # attach a GTR process to range 11:20
# gtr<-GTR()
# attachProcess(s,gtr,11:20)
# # set and get rate multipliers for gtr
# setRateMultipliers(s, gtr, c(0,5,1), 11:20)
# getRateMultipliers(s, gtr, 11:20)
# # get processes from range 1:5
# getProcesses(s,1:5)
# # replace the processes with a (GTR, JC69), JC69 pattern
# s$processes<-list(list(GTR(), JC69()), list(JC69()))
# # get processes from range 1:2
# getProcesses(s,1:2)
# # get unique processes
# s$uniqueProcesses
# # get unique alphabets
# s$uniqueAlphabets
# # get symbol frequencies
# getSymbolFreqs(s)
# # get the big rate
# s$bigRate
# # get a vector of total rates from range 1:4
# getTotalRatesFromRange(s,1:4)
# # get a vector of cumulative rates from range 1:4
# getCumulativeRatesFromRange(s,1:4)
# # reset all site states
# clearStates(s)
# s
# # sample states from the equilibrium distributions
# # of the attached substitution processes
# sampleStates(s)
# s
# # clone s
# s.clone<-clone(s)
# # insert a sequence in s.clone after position 2
# insertSequence(s.clone,NucleotideSequence(string="AAAAAA"),2)
# s.clone
# # delete positions 1,2,3 and 10
# deleteSubSequence(s.clone, c(1:3,10))
# s.clone
# # copy positions 7:10 into a new sequence object
# sc<-copySubSequence(s.clone, 7:10)
# sc
# # get events from sc in the range 1:2
# getEvents(sc,1:2)
# }
#
# @author
#
# \seealso{
# Alphabet Site Process Event
# }
#
#*/###########################################################################
setConstructorS3(
"Sequence",
function(
name=NA,
string=NA,
length=NA,
alphabets=NA,
processes=NA,
ancestral.obj=NA,
...
){
# Marking the instance as static by default:
STATIC<-TRUE;
# Extending the PSRoot class:
this<-extend(
PSRoot(),
"Sequence",
.name="Anonymous",
.length=NA,
.sites=list(),
.ancestral.obj=NA,
.cumulative.rates=NA,
.total.rates=NA,
.cumulative.rate.flag=TRUE,
.flagged.sites=integer(0),
.write.protected=FALSE,
.is.sequence=TRUE,
.root.ins=NA
);
# Initializing the variables for length and states:
len<-0;
str<-list();
# Optional argument: name
if(!missing(name)) {
this$name<-name;
STATIC<-FALSE;
}
# The user can specify a sequence
# or the sequence length, but not both.
if (!missing(string) & !missing(length)) {
throw("You can specify the sequence, or the sequence length, but not both!\n");}
else if (!missing(string)){
STATIC<-FALSE;
# An alphabet list must be specified along the sequence!
if(missing(alphabets)) {throw("A list of valid alphabets must be specified when a string is given!\n");}
}
# Deal with the string or length argument:
if (!missing(length)) {
STATIC<-FALSE;
len<-length;
}
else if( !missing(string) ) {
str<-strsplit(string,split="",fixed=TRUE)[[1]];
len<-length(str);
}
this$.length<-len;
root.ins<-NA;
if (!is.Process(Sequence$.root.ins)) {
# Dummy proces used as ancestral object for sites.
this$.root.ins<-Process(name="Root insertion process");
this$.root.ins$comments<-"This is just a dummy process object serving as ancestral for newly created site and sequence objects.";
root.ins<-this$.root.ins;
} else {
root.ins<-Sequence$.root.ins
}
# Site template object:
site.template<-Site(
ancestral=root.ins,
sequence=this
);
# Clone and store the site objects:
if(!STATIC) {
if ( len > 0 ) {
for(position in 1:len) {
this$.sites[[position]]<-clone.Object(site.template);
}
}
}
# Optional argument: ancestral object
if (!missing(ancestral.obj)) {
STATIC<-FALSE;
this$ancestral<-ancestral.obj;
} else {
this$ancestral<-root.ins;
}
# Setting the alphabets:
if(!missing(alphabets)) {
STATIC<-FALSE;
# setAlphabets will check the arguments
setAlphabets(this, alphabets);
}
# Setting the processes:
if (!missing(processes)) {
STATIC<-FALSE;
# setProcesses will take care about the arguments
# and deal with alphabet mismatch.
setProcesses(this,processes)
}
# Initializing these vectors properly is
# importtant for the insertion method!
this$.total.rates<-double(len);
this$.cumulative.rates<-double(len);
if(!STATIC){
# Now we are prepared to set the states:
if (!missing(string)) {
setStates(this, str);
}
# Calculate cumulative rates for the first time, but only if
# states are defined. This is expensive, as total rates are calculated.
if (!missing(string) & (length(str) > 0) ) {
.recalculateCumulativeRates(this);
}
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: is.Sequence
##
###########################################################################/**
#
# @RdocDefault is.Sequence
#
# @title "Check whether an object inherits from the Sequence class"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
# \examples{
# # create some objects
# seq<-Sequence(length=10)
# a<-Alphabet()
# # check if they inherit from Sequence
# is.Sequence(seq)
# is.Sequence(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"is.Sequence",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.sequence)){return(TRUE)}
if ( inherits(this, "Sequence")) {
this$.is.sequence<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{omit.sites}{Do not check aggregated site objects.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="Sequence",
function(
this,
omit.sites=FALSE,
...
){
if(this$length != length(this$.sites)) {
throw("Sequence length inconsistency detected");
} else if (length(this$.cumulative.rates) != this$.length) {
throw("Cumulative rates vector length mismatch!\n");
} else if (length(this$.total.rates) != this$.length) {
throw("Total rates vector length mismatch!\n");
} else if (!identical(this$.cumulative.rates, cumsum(this$.total.rates))) {
throw("Cumulative rates vector is not consistent with total rates vector!\n");
}
if(!is.numeric(this$.flagged.sites)) {
throw("Flagged sites vector is not numeric!\n");
} else if (length(this$.flagged.sites) > 0) {
if ( (min(this$.flagged.sites) < 1) | ( max(this$.flagged.sites) > this$.length) ) {
throw("Inconsistency in the flagged sites vector!\n");
}
}
if(!is.character(this$.name)) {
throw("Sequence name is invalid!\n");
} else if(stringLength(this$.name) == 0) {
throw("Sequence name is of length zero!\n");
}
if(!is.Sequence(this$.ancestral.obj) & !is.Process(this$.ancestral.obj)) {
throw("The ancestral object is invalid!\n");
}
if(!is.logical(this$.cumulative.rate.flag)) {
throw("Cumulative rate flag is not logical!\n");
}
# Calling consistency check on sites.
# This will be painfully slow!
if(!omit.sites){
for(site in this$.sites){
checkConsistency(site);
}
}
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getId
##
###########################################################################/**
#
# @RdocMethod getId
#
# @title "Get the unique identifier of a Sequence object"
#
# \description{
# @get "title".
# The identifier is the concatenation of the object name and the object hash code as returned
# by hashCode().
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A charcter vector of length one.
# }
#
# \examples{
# # create a Sequence object.
# s<-Sequence(length=5)
# # get id
# getId(s)
# # get id via virtual field
# s$id
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getId",
class="Sequence",
function(
this,
...
){
this.class<-class(this)[1];
id<-paste(this.class,this$.name,hashCode(this),sep=":");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setId
##
###########################################################################/**
#
# @RdocMethod setId
#
# @title "Forbidden action: setting the unique identifier of a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setId",
class="Sequence",
function(
this,
value,
...
){
throw("Id is generated automatically and it cannot be set!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getName
##
###########################################################################/**
#
# @RdocMethod getName
#
# @title "Get the name of a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create object
# s<-Sequence(length=10);
# # get object name
# getName(s)
# # get name via virtual field
# s$name
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getName",
class="Sequence",
function(
this,
...
){
this$.name;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setName
##
###########################################################################/**
#
# @RdocMethod setName
#
# @title "Set the name of a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{new.name}{A character vector of length one.}
# \item{...}{Not used.}
# }
#
# \value{
# The new object name (invisible).
# }
#
# \examples{
# # create a Sequence object
# s<-Sequence(name="MySeq",length=4)
# # get sequence name
# s$name
# # rename object
# setName(s,"SO")
# s$name
# # rename via virtual field
# s$name<-"SeqSeq"
# s$name
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setName",
class="Sequence",
function(
this,
new.name,
...
){
.checkWriteProtection(this);
this$.name<-as.character(new.name);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getString
##
###########################################################################/**
#
# @RdocMethod getString
#
# @title "Get the string representation of a Sequence object"
#
# \description{
# @get "title".
# The string representation is the concatenation of the states of the
# aggregated Site object. Undefined states (NA-s) are represented by question marks.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create object
# s<-Sequence(length=10)
# # get character representation
# getString(s) # a bunch of '?'-s
# # get string reperesentation via virtual field
# s$string
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getString",
class="Sequence",
function(
this,
...
){
str<-character();
for(site in this$.sites){
if(is.na(site$.state)){
if(is.Alphabet(site$.alphabet)){
str<-c(str,rep("?",site$.alphabet$.symbolLength));
}
else {
str<-c(str,"?");
}
}
else {
str<-c(str,site$.state);
}
}
return(paste(str,collapse=""));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setString
##
###########################################################################/**
#
# @RdocMethod setString
#
# @title "Forbidden action: setting the string representation of a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setString",
class="Sequence",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getLength
##
###########################################################################/**
#
# @RdocMethod getLength
#
# @title "Get the number of Site objects aggregated in a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# An integer vector of length one.
# }
#
# \examples{
# # create a Sequence object
# s<-Sequence(length=5)
# # get sequence length
# getLength(s)
# # get length via virtual field
# s$length
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getLength",
class="Sequence",
function(
this,
...
){
this$.length;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setLength
##
###########################################################################/**
#
# @RdocMethod setLength
#
# @title "Forbidden action: setting the length of a Sequence object"
#
# \description{
# @get "title".
# The length of the Sequence objects can be specified when the object is constructed,
# or modified later by the "insertSequence" and "deleteSubSequence" methods.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setLength",
class="Sequence",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSites
##
###########################################################################/**
#
# @RdocMethod getSites
#
# @title "Get the list of the Site object aggregated in a Sequence object"
#
# \description{
# @get "title".
# Warning: there is no setSites method!
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of Site objects.
# }
#
# \examples{
# # create a sequence object
# s<-Sequence(alphabets=list(NucleotideAlphabet()),string="AATTGCCC")
# # get the list of aggregated Site objects
# getSites(s)
# # get Site objects via virtual field
# s$sites
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSites",
class="Sequence",
function(
this,
...
){
this$.sites;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getStates
##
###########################################################################/**
#
# @RdocMethod getStates
#
# @title "Get the states of a set of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{index}{An integer vector specifying a set of positions.
# It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector.
# }
#
# \examples{
# # create a sequence object
# s<-Sequence(alphabets=list(NucleotideAlphabet()),string="AATTGCCCCCTTGG")
# # get all Site states
# getStates(s)
# # get the states for a collection of sites
# getStates(s,c(1:3,5,8))
# # get states via virtual field
# s$states
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getStates",
class="Sequence",
function(
this,
index,
...
){
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
lapply(
this$.sites[index],
function(site) {
site$.state;
}
);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setStates
##
###########################################################################/**
#
# @RdocMethod setStates
#
# @title "Set the states for a set of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# The value vector is recycled, which is useful when creating repeated patterns.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{value}{A character vector containg the states (recycled if shorter than the index vector). The states must be compatible with the corresponding Alphabet object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
# \examples{
# # create a sequence object of length 10
# s<-Sequence(alphabets=list(NucleotideAlphabet()),length=10)
# # set the states in some ranges
# setStates(s,c("A","T","A"),index=1:5)
# setStates(s,c("G","C"),index=6:10)
# # display sequence
# s
# # set the states for the whole Sequence object
# setStates(s,c("A","T","T","A"))
# s
# # set states via virtual field
# s$states<-c("A","T")
# s
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setStates",
class="Sequence",
function(
this,
value,
index,
...
){
.checkWriteProtection(this);
if(missing(value)) {
throw("No new values specified!\n");
}
else if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
# Recycling value vector by using rep().
if (length(value) < length(this$.sites) ) {
value<-rep(as.character(value),length.out=length(index))
}
for (i in 1:length(index)) {
this$.sites[[ index[[i]] ]]$state<-value[i];
}
# Flagging the changed sites:
this$.cumulative.rate.flag<-TRUE;
this$.flagged.sites<-c(this$.flagged.sites, index);
.recalculateCumulativeRates(this);
invisible(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAlphabets
##
###########################################################################/**
#
# @RdocMethod getAlphabets
#
# @title "Get the list of the Alphabet objects attached to the Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of Alphabet objects.
# }
#
# \examples{
# # create a Sequence object with NucleotideAlphabet
# #and BinaryAlphabet objects attached
# s<-Sequence(alphabets=list(NucleotideAlphabet(),BinaryAlphabet()),length=5)
# setStates(s,c("A","0"))
# # get the list of attached Alphabet objects
# getAlphabets(s)
# # get Alphabets from a range
# getAlphabets(s,c(2:3,5))
# # get alphabets via virtual field
# s$alphabets
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAlphabets",
class="Sequence",
function(
this,
index,
...
){
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
lapply(
this$.sites[index],
function(site) {
site$alphabet;
}
);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setAlphabets
##
###########################################################################/**
#
# @RdocMethod setAlphabets
#
# @title "Assotiate Alphabet objects to a set of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{value}{A list of Alphabet objects, recycled if shorter than the index vector.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
# \examples{
# # create a Sequence object
# s<-Sequence(length=10)
# # set the alphabets for range 1:5
# setAlphabets(s,list(NucleotideAlphabet(),BinaryAlphabet()),1:5)
# # set the alphabets for range 6:10
# setAlphabets(s,list(AminoAcidAlphabet()),6:10)
# # get the list of attached Alphabet objects
# getAlphabets(s)
# # get Alphabets from a range
# getAlphabets(s,c(2:3,5))
# # set alphabets via virtual field
# s$alphabets<-list(BinaryAlphabet(),NucleotideAlphabet())
# # get alphabets via virtual field
# s$alphabets
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setAlphabets",
class="Sequence",
function(
this,
value,
index,
...
){
.checkWriteProtection(this);
if(missing(value)) {
throw("No new values specified!\n");
}
if(!is.list(value)) {
throw("The value parameter must be a list!\n");
} else {
for(a in value) {
if(!is.Alphabet(a)) {
throw("The value parameter must be a list of valid alphabet objects!\n");
}
}
}
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
# Recycling value vector. rep() cannot be used here,
# because we loose the object references!
value.counter<-1;
for (i in index) {
if(value.counter > length(value)) {
value.counter<-1;
}
setAlphabet(this$.sites[[i]], value[[value.counter]]);
value.counter<-(value.counter + 1);
}
invisible(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getUniqueAlphabets
##
###########################################################################/**
#
# @RdocMethod getUniqueAlphabets
#
# @title "Get the list of unique Alphabet objects associated to Site objects aggaregated by a Sequence object"
#
# \description{
# @get "title".
# The returned list contains unique instances of the Alphabet class. The symbol sets are not compared, so
# two instances of the same class are considered to be different.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of Alphabet objects.
# }
#
# \examples{
# # create a Sequence object with some Alphabet objects attached
# s<-Sequence(
# alphabets=list(NucleotideAlphabet(),
# BinaryAlphabet(),
# NucleotideAlphabet()),
# length=10
# )
# # get the list of attached alphabets
# s$alphabets
# # get the unique list of attahced Alphabet objects
# getUniqueAlphabets(s)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getUniqueAlphabets",
class="Sequence",
function(
this,
...
){
tmp<-list();
lapply(
this$.sites,
function(site) {
tmp<<-c(tmp,list(site$.alphabet))
}
);
return(unique(tmp));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setUniqueAlphabets
##
###########################################################################/**
#
# @RdocMethod setUniqueAlphabets
#
# @title "Forbidden action: setting the list of unique Alphabet objects attached to the Site object aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setUniqueAlphabets",
class="Sequence",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: attachProcess
##
###########################################################################/**
#
# @RdocMethod attachProcess
#
# @title "Attach a Process object to a set of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A Process object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
# \examples{
# # create a Sequence object of length 6
# s<-Sequence(length=10,alphabets=list(NucleotideAlphabet()))
# # attach a JC69 substitution process
# attachProcess(s,JC69())
# # get the list of attached processes
# s$processes
# # attach the GTR substitution process to range 3:6
# attachProcess(s,GTR(),3:6)
# # get the list of attached processes
# s$processes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"attachProcess",
class="Sequence",
function(
this,
process,
index,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(!is.Process(process)){
throw("Process object invalid!\n");
}
}
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
for(i in index){
attachProcess(this$.sites[[i]],process);
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: detachProcess
##
###########################################################################/**
#
# @RdocMethod detachProcess
#
# @title "Detach a Process object from a set of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A Process object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
# \examples{
# # create a sequence object with two processes attached
# p<-JC69()
# s<-Sequence(length=4,alphabets=list(NucleotideAlphabet()),processes=list(list(p,K80())))
# # get the list of attached processes
# s$processes
# # detach JC69 from range c(1,4)
# detachProcess(s,p,c(1,4))
# s$processes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"detachProcess",
class="Sequence",
function(
this,
process,
index,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(!is.Process(process)){
throw("Process object invalid!\n");
}
}
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
lapply(
this$.sites[index],
function(site) {
detachProcess(site,process);
}
);
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getProcesses
##
###########################################################################/**
#
# @RdocMethod getProcesses
#
# @title "Get the Process objects attached to the Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of lists of Process objects.
# }
#
# \examples{
# # create a sequence object with some processes attached
# s<-Sequence(
# length=4,
# alphabets=list(NucleotideAlphabet()),
# processes=list(list(JC69(),K80()),list(GTR()))
# )
# # get the list of lists of attached processes from positions 1 and 3
# getProcesses(s,c(1,3))
# # get processes via virtual field
# s$processes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getProcesses",
class="Sequence",
function(
this,
index,
...
){
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
lapply(
this$.sites[index],
function(site) {
site$processes;
}
);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getUniqueProcesses
##
###########################################################################/**
#
# @RdocMethod getUniqueProcesses
#
# @title "Get the list of unique Process instances attached to the Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of Process objects.
# }
#
# \examples{
# # create a sequence object and attach processes
# p<-JC69()
# s<-Sequence(
# length=4,
# alphabets=list(NucleotideAlphabet()),
# processes=list(list(p,K80()),list(p))
# )
# # get the unique list of attached Process instances
# getUniqueProcesses(s)
# # via virtual field
# s$uniqueProcesses
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getUniqueProcesses",
class="Sequence",
function(
this,
...
){
tmp<-list();
lapply(
this$.sites,
function(site) {
tmp<<-c(tmp,site$processes)
}
);
return(unique(tmp));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setUniqueProcesses
##
###########################################################################/**
#
# @RdocMethod setUniqueProcesses
#
# @title "Forbidden action: setting the list of unique Process instances attached to the sites of a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setUniqueProcesses",
class="Sequence",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setProcesses
##
###########################################################################/**
#
# @RdocMethod setProcesses
#
# @title "Specify a set of Process objects to be attached to a set of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# The Process objects in a given inner list correspond to the set of processes to be attached to one Site object.
# Process objects already attached to a given Site are skipped. Attached processes which are not memebers of the list
# are detached, so specifying an empty list will detach all processes.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{value}{A list of list of Process objects, recycled if shorter than the index vector.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
# \examples{
# # create a sequence of length 5
# s<-Sequence(length=5,alphabets=list(NucleotideAlphabet()));
# # set a pattern of processes
# setProcesses(s,list(list(JC69(),K81())))
# # get attached processes
# s$processes
# # detach all processes from range 1:3
# setProcesses(s,list(list()),1:3)
# s$processes
# # detach all processes via virtual field
# s$processes<-list(list())
# # create a process pattern in the full sequence via virtual field
# s$processes<-list(list(JC69()),list(GTR(),K80()))
# s$processes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setProcesses",
class="Sequence",
function(
this,
value,
index,
...
){
.checkWriteProtection(this);
if(!is.list(value)) {
throw("The value parameter must be a list!\n");
} else {
lapply(
value,
function(element) {
if(!is.list(element)){
throw("The value parameter must be a list of lists containing process objects!\n");
}
}
);
}
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
value.counter<-1;
# Recycling value vector. rep() cannot be used here,
# because we loose the object references!
for (i in index) {
if(value.counter > length(value)) {
value.counter<-1;
}
setProcesses(this$.sites[[i]], value[[value.counter]]);
value.counter<-(value.counter + 1);
}
invisible(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setParameterAtSites
##
###########################################################################/**
#
# @RdocMethod setParameterAtSites
#
# @title "Set the values of a site-process specific paramater for a process and a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A valid Process object.}
# \item{id}{The identifier of the site-process specific parameter.}
# \item{value}{A vector containing the new values of the site-process specific parameter, recycled if shorter than the index vector. It should be consistent with the type of the parameter.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
# \examples{
# # create a sequence, attach a process
# p<-K80()
# s<-Sequence(length=6,alphabets=list(NucleotideAlphabet()),processes=list(list(p)))
# # set a new pattern of rate multipliers in the range 1:3,
# # the default value is 1.0 by the way
# setParameterAtSites(s,p,"rate.multiplier",c(2,3),1:3)
# # get rate multipliers
# getParameterAtSites(s,p,"rate.multiplier")
# # set a new value for the whole sequence
# setParameterAtSites(s,p,"rate.multiplier",0.5)
# # get rate multipliers
# getParameterAtSites(s,p,"rate.multiplier")
# }
#
# @author
#
# \seealso{
# Site Process @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setParameterAtSites",
class="Sequence",
function(
this,
process,
id,
value,
index,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(process)) {
throw("No process given!\n");
}
else if(!is.Process(process)){
throw("Process object invalid!\n");}
else if (missing(id)) {
throw("No site-process specific parameter id given!\n");
} else if (!is.character(id)) {
throw("Parameter id must be character!\n");
} else if (missing(value)){
throw("No new value given!\n");
}
}
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
if(length(value) == 1) {
lapply(
this$.sites[index],
function(site){
setParameterAtSite(process,site,id,value);
}
);
} else {
counter<-1;
lapply(
this$.sites[index],
function(site){
if( counter > length(value) ){
counter<<-1;
}
setParameterAtSite(process,site,id,value[[counter]]);
counter<<-(counter+1);
}
);
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateMultipliers
##
###########################################################################/**
#
# @RdocMethod setRateMultipliers
#
# @title "Set the values of the rate multiplier parameters for a given Process object and a collection of Site object aggregated by a Sequence object"
#
# \description{
# @get "title".
# This method just calls \code{setParameterAtSites(this=this,process=process,id="rate.multiplier",value=value,index=index)} See setParameterAtSites.Sequence for details.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A valid Process object.}
# \item{value}{A numeric vector containing the new values of the site-process specific parameter, recycled if shorter than the index vector.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
#
# @author
#
# \seealso{
# setParameterAtSites.Sequence
# }
#
#*/###########################################################################
setMethodS3(
"setRateMultipliers",
class="Sequence",
function(
this,
process,
value,
index,
...
){
if(missing(process)){
throw("No process given!\n");
}
else if(missing(value)){
throw("No value provided!\n");
}
#else if(!is.GeneralSubstitution(process)){
# throw("The specified process is not a substitution process!\n");
#}
setParameterAtSites(this=this,process=process,id="rate.multiplier",value=value,index=index);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateMultipliers
##
###########################################################################/**
#
# @RdocMethod getRateMultipliers
#
# @title "Get the values of the rate multiplier parameters for a given Process object and a collection of Site object aggregated by a Sequence object"
#
# \description{
# @get "title".
# This method just calls \code{getParameterAtSites(this=this,process=process,id="rate.multiplier",index=index)} See getParameterAtSites.Sequence for details.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A valid Process object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector with the current values of the rate multiplier in the specified range.
# }
#
#
# @author
#
# \seealso{
# setParameterAtSites.Sequence
# }
#
#*/###########################################################################
setMethodS3(
"getRateMultipliers",
class="Sequence",
function(
this,
process,
index,
...
){
if(missing(process)){
throw("No process given!\n");
}
rm<-getParameterAtSites(this=this,process=process,id="rate.multiplier",index=index);
return(as.numeric(lapply(rm,function(param){param$value})));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getParameterAtSites
##
###########################################################################/**
#
# @RdocMethod getParameterAtSites
#
# @title "Get the values of a site-process specific paramater for a process and a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A valid Process object.}
# \item{id}{The identifier of the site-process specific parameter.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of site specific paramters. A site specific paramter is a list storing the id, the name, the value
# and the type of the parameter.
# }
#
# \examples{
# # create a sequence, attach a process
# p<-K80()
# s<-Sequence(length=6,alphabets=list(NucleotideAlphabet()),processes=list(list(p)))
# # set a new pattern of rate multipliers in the
# # range 1:3, the default value is 1.0 by the way
# setParameterAtSites(s,p,"rate.multiplier",c(2,3),1:3)
# # get rate multipliers
# getParameterAtSites(s,p,"rate.multiplier")
# # set a new value for the whole sequence
# setParameterAtSites(s,p,"rate.multiplier",0.5)
# # get rate multipliers
# getParameterAtSites(s,p,"rate.multiplier")
# }
#
# @author
#
# \seealso{
# Site Process @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getParameterAtSites",
class="Sequence",
function(
this,
process,
id,
index,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(process)) {
throw("No process given!\n");
}
else if(!is.Process(process)){
throw("Process object invalid!\n");}
else if (missing(id)) {
throw("No site-process specific parameter id given!\n");
} else if (!is.character(id)) {
throw("Parameter id must be character!\n");
}
}
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
lapply(
this$.sites[index],
function(site){
getParameterAtSite(process,site,id);
}
);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEvents
##
###########################################################################/**
#
# @RdocMethod getEvents
#
# @title "Get the list of active Event objects for a set of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of Event objects.
# }
#
# \examples{
# # create a sequence with a process attached
# s<-Sequence(
# string="ATGC",
# alphabets=list(NucleotideAlphabet()),
# processes=list(list(JC69()))
# )
# # get the active events from range 1:3
# getEvents(s,1:3)
# # get all active events via virtual field
# s$events
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEvents",
class="Sequence",
function(
this,
index,
...
){
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
tmp<-list();
for (i in index){
# Setting the .positions field for then Events.
this$.sites[[i]]$.position<-i;
tmp<-c(tmp, getEvents(this$.sites[[i]]));
# Deleting the .position field;
this$.sites[[i]]$.position<-NULL;
}
tmp;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getTotalRatesFromRange
##
###########################################################################/**
#
# @RdocMethod getTotalRatesFromRange
#
# @title "Get the vector of total site rates for a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector.
# }
#
# \examples{
# # create a sequence with some processes attached
# s<-Sequence(
# string="ATGC",
# alphabets=list(NucleotideAlphabet()),
# processes=list(list(JC69()),list(JC69(),GTR()))
# )
# # get total rates for positions 1 and 3
# getTotalRatesFromRange(s,c(1,3))
# # get all total rates via virtual field
# s$totalRates # via the "getTotalRates.Sequence" method
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getTotalRatesFromRange",
class="Sequence",
function(
this,
index,
...
){
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
if (this$.cumulative.rate.flag){
.recalculateCumulativeRates(this);
}
this$.total.rates[index];
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getTotalRates
##
###########################################################################/**
#
# @RdocMethod getTotalRates
#
# @title "Get the total site rates from a Sequence object"
#
# \description{
# @get "title".
# This method simply calls \code{getTotalRatesFromRange(this)}.
# See \code{getTotalRatesFromRange.Sequence} for more details.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector containing the total site rates.
# }
#
# @author
#
# \seealso{
# getTotalRatesFromRange.Sequence
# }
#
#*/###########################################################################
setMethodS3(
"getTotalRates",
class="Sequence",
function(
this,
...
){
getTotalRatesFromRange(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setTotalRates
##
###########################################################################/**
#
# @RdocMethod setTotalRates
#
# @title "Forbidden action: setting the list of total site rates for a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setTotalRates",
class="Sequence",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAncestral
##
###########################################################################/**
#
# @RdocMethod getAncestral
#
# @title "Get the ancestral object of a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A Sequence object or a Process object.
# }
#
# \examples{
# # create a sequence object
# s<-Sequence(length=4)
# # get ancestral object
# getAncestral(s) # newly created sequences have the "Root insertion process" as ancestral
# # clone sequence
# cs<-clone(s)
# # get ancestral object id via virtual field
# cs$ancestral$id
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAncestral",
class="Sequence",
function(
this,
...
){
this$.ancestral.obj;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getCumulativeRatesFromRange
##
###########################################################################/**
#
# @RdocMethod getCumulativeRatesFromRange
#
# @title "Get the cumulative site rates for a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector.
# }
#
# \examples{
# # create a sequence with some processes attached
# s<-Sequence(
# string="ATGC",
# alphabets=list(NucleotideAlphabet()),
# processes=list(list(JC69()),list(JC69(),GTR()))
# )
# # get cumulative rates for positions 1 and 3
# getCumulativeRatesFromRange(s,c(1,3))
# # get all cumulative rates via virtual field
# s$cumulativeRates # via the "getCumulativeRates.Sequence" method
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getCumulativeRatesFromRange",
class="Sequence",
function(
this,
index,
...
){
if (missing(index)) {
index<-seq(along.with=this$.sites);
} else {
index<-.checkIndexSanity(this, index);
}
if (this$.cumulative.rate.flag){
.recalculateCumulativeRates(this);
}
this$.cumulative.rates[index];
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
setMethodS3(
".getCumulativeRatesFast",
class="Sequence",
function(
this,
...
){
if (this$.cumulative.rate.flag){
.recalculateCumulativeRates(this);
}
this$.cumulative.rates;
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .recalculateCumulativeRates
##
setMethodS3(
".recalculateCumulativeRates",
class="Sequence",
function(
this,
target.site,
...
){
length<-this$.length;
if(length == 0){
return();
}
total.rates<-this$.total.rates;
sites<-this$.sites;
flagged.sites<-this$.flagged.sites;
if( length(flagged.sites) == 0 ) {
# Fresh start:
total.rates<-as.numeric(lapply(sites,getTotalRate));
} else {
# We have some flagged sites, recalculate just their total rates:
total.rates[flagged.sites]<-as.numeric(lapply(sites[flagged.sites],getTotalRate));
}
this$.total.rates<-total.rates;
this$.cumulative.rates<-cumsum(total.rates);
this$.flagged.sites<-integer(0);
this$.cumulative.rate.flag<-FALSE;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getCumulativeRates
##
###########################################################################/**
#
# @RdocMethod getCumulativeRates
#
# @title "Get the total site rates from a Sequence object"
#
# \description{
# @get "title".
# This method simply calls \code{getCumulativeRatesFromRange(this)}.
# See \code{getCumulativeRates.Sequence} for more details.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector containing the total site rates.
# }
#
# @author
#
# \seealso{
# getCumulativeRatesFromRange.Sequence
# }
#
#*/###########################################################################
setMethodS3(
"getCumulativeRates",
class="Sequence",
function(
this,
...
){
getCumulativeRatesFromRange(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setCumulativeRates
##
###########################################################################/**
#
# @RdocMethod setCumulativeRates
#
# @title "Forbidden action: setting the cumulative rates for the sites aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setCumulativeRates",
class="Sequence",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getBigRate
##
###########################################################################/**
#
# @RdocMethod getBigRate
#
# @title "Get the sum of all active event rates from a Sequence object"
#
# \description{
# @get "title".
# The sum of active event rates depends on all Site object states and on the attached Process objects.
# It basically returns the last element of the cumulative site rates vector.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
# # create a nucleotide sequence attach a process
# s<-NucleotideSequence(length=5);
# s$processes<-list(list(JC69()))
# # get the sum of active event rates
# getBigRate(s) # returns NA because site states are undefined
# # set site states
# s$states<-c("A","T")
# # get big rate via virtual field
# s$bigRate
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getBigRate",
class="Sequence",
function(
this,
...
){
if (length(this$.sites) > 0) {
if(this$.cumulative.rate.flag) {
.recalculateCumulativeRates(this);
}
return(this$.cumulative.rates[this$.length]);
} else {
return(NA);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setBigRate
##
###########################################################################/**
#
# @RdocMethod setBigRate
#
# @title "Forbidden action: setting the sum of total active event rates for a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setBigRate",
class="Sequence",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setAncestral
##
###########################################################################/**
#
# @RdocMethod setAncestral
#
# @title "Set the ancestral object of a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{value}{A Sequence or a Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# The new ancestral object (invisible).
# }
#
# \examples{
# # create a nucleotide sequence and a process object
# s<-NucleotideSequence(string="AGCT")
# p<-Process(name="MyProcess")
# # set the p as the ancestral of s
# setAncestral(s,p)
# s$ancestral
# # clone s
# cs<-clone(s)
# # set cs as ancestral of s via virtual field
# s$ancestral<-cs
# # get ancestral ids
# s$ancestral$id
# cs$ancestral$id
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setAncestral",
class="Sequence",
function(
this,
value,
...
){
.checkWriteProtection(this);
if (!is.Sequence(value) & ! is.Process(value)) {
throw("Ancestral object must be a sequence or a process!\n");
} else {
this$.ancestral.obj<-value;
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: clone.Sequence
##
###########################################################################/**
#
# @RdocMethod clone
#
# @title "Clone a Sequence object"
#
# \description{
# @get "title".
#
# The cloning of Sequence objects involves the cloning of all aggregated Site objects. Because of that the
# cloning of long sequences is quite expensive.
# The cloned Site objects have the orginal Site objects as ancestral.
# The new Sequence objects has the original object as ancestral.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A Sequence object.
# }
#
# \examples{
# # cretate a nucleotide sequence
# s<-NucleotideSequence(string="ATG")
# # clone the sequence
# cs<-clone(s)
# # get some properties
# equals(s,s)
# equals(s,cs)
# cs$ancestral
# cs$sites[[1]]$ancestral
# }
#
# @author
#
# \seealso{
# Sequence clone.Object
# }
#
#*/###########################################################################
setMethodS3(
"clone",
class="Sequence",
function(
this,
...
){
# Cloning the whole sequence object:
that<-clone.Object(this)
# Disabling write protection:
if(that$writeProtected) {
that$writeProtected<-FALSE
}
# Setting the ancestral sequence:
that$.ancestral.obj<-this
# Resetting comments:
that$.comments<-list()
# Cloning sites:
clone.sites<-that$.sites
if(this$.length > 0) {
for (i in 1:this$.length) {
site<-this$.sites[[i]]
clone<-clone.Object(site)
clone$.ancestral<-site
clone$.sequence<-that
clone.sites[[i]]<-clone
}
}
that$.sites<-clone.sites
# Setting the name:
that$name<-paste("clone of",this$.name)
return(that)
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getWriteProtected
##
###########################################################################/**
#
# @RdocMethod getWriteProtected
#
# @title "Check if the object is write protected"
#
# \description{
# @get "title".
# Write protected objects cannot be modified through get/set methods and virtual fields.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE
# }
#
# \examples{
#
# # create an object
# o<-Sequence()
# # toggle write protection
# o$writeProtected<-TRUE
# # check if it's write protected
# getWriteProtected(o)
# # check write protection via virtual field
# o$writeProtected
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getWriteProtected",
class="Sequence",
function(
this,
...
){
this$.write.protected;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkIndexSanity
##
setMethodS3(
".checkIndexSanity",
class="Sequence",
function(
this,
index,
...
){
if (length(index) == 0 ) {
return(c());
}
if(!exists(x="PSIM_FAST")){
if( length(index) == 1 ) {
if(is.na(index)) {
warning("Index vector is NA! Coercing to empty vector!\n");
return(c());
}
if (is.nan(index)) {
warning("Index vector is NaN! Coercing to empty vector!\n");
return(c());
}
}
if(min(index) < 1 ) {
throw("Index vector element ",min(index)," too small!\n");
}
if( max(index) > this$.length ) {
throw("Index vector element ",max(index)," too big!\n");
}
}
return(index);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setWriteProtected
##
###########################################################################/**
#
# @RdocMethod setWriteProtected
#
# @title "Set the write protection field for an object"
#
# \description{
# @get "title".
# Write protected objects cannot be modified through get/set methods and virtual fields.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{A logical vector of size one.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE or FALSE.
# }
#
# \examples{
#
# # create an object
# o<-Sequence()
# # toggle write protection
# setWriteProtected(o,TRUE)
# # check write protection
# o$writeProtected
# # set write protection via virtual field
# o$writeProtected<-FALSE
# o$writeProtected
#
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setWriteProtected",
class="Sequence",
function(
this,
value,
...
){
if(!is.logical(value)) {throw("The new value must be logical!\n")}
else {
this$.write.protected<-value;
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkWriteProtection
##
setMethodS3(
".checkWriteProtection",
class="Sequence",
function(
this,
value,
...
){
if(getWriteProtected(this)) {throw("Cannot set value because the object is write protected!\n")}
else {return(FALSE)}
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.Sequence
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-Sequence()
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="Sequence",
function(
object,
...
){
this<-object;
this$.summary$"Name"<-this$name;
this$.summary$"Id"<-this$id;
this$.summary$"Length"<-this$length;
this$.summary$"Big rate"<-this$bigRate;
this$.summary$"Ancestral object"<-this$ancestral$id;
if(this$.cumulative.rate.flag) {
this$.summary$"Cumulative rate flag"<-TRUE;
}
if(length(this$.flagged.sites) > 0 ) {
this$.summary$"Flagged sites"<-paste(this$.flagged.sites,collapse=" ");
}
if(this$writeProtected) {
this$.summary$"Write protected"<-TRUE;
}
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: as.character.Sequence
##
###########################################################################/**
#
# @RdocMethod as.character
#
# @title "Get the string representation of a Sequence object"
#
# \description{
# @get "title".
# The string representation is the concatenation of the states of the
# aggregated Site object. Undefined states (NA-s) are represented by question marks.
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create object
# s<-Sequence(length=10)
# # get character representation
# as.character(s)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"as.character",
class="Sequence",
function(
x,
...
){
getString(x);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: plot
##
###########################################################################/**
#
# @RdocMethod plot
#
# @title "Plot the total site rates for a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A Sequence object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE or FALSE.
# }
#
# \examples{
# # create a nucleotide sequence with a process attached
# s<-NucleotideSequence(string="ATGGCCA",processes=list(list(JC69())))
# # plot total rates in range 1:4
# plot(s,1:4)
# # plot all total rates
# plot(s)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"plot",
class="Sequence",
function(
x,
index=NA,
...
){
this<-x;
if(this$length == 0) {
warning("The sequence leght is zero, nothing to plot here!\n");
return(invisible(FALSE));
}
if( length(unique(this$totalRates)) == 1 & any(is.na(unique(this$totalRates))) ){
warning("The total rates are undefined, nothing to plot here!\n");
return(invisible(FALSE));
}
else {
if(missing(index)) {
index<-seq(along.with=1:this$length,by=1);
}
if(this$.cumulative.rate.flag){
.recalculateCumulativeRates(this);
}
what<-this$.total.rates[c(index)]
plot(
x=index,
y=what,
type="h",
lwd=1,
col="blue",
main=paste("Total rate plot for sequence", this$id),
xlab="Position",
ylab="Total rate",
ylim=c(0,max(what)),
xlim=c(min(index),max(index)),
xaxt="n"
);
axis(side=1, at=index, labels=index);
return(invisible(TRUE));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: plotParameterAtSites
##
###########################################################################/**
#
# @RdocMethod plotParametersAtSites
#
# @title "Plot the value of a site-process specifc paramter for a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# The type of the paramter must be numeric. The Process object must be attached to all positions specified
# in the index vector.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A Process object.}
# \item{id}{The identifier of the site-process specific parameter.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE or FALSE.
# }
#
# \examples{
# # create a nucleotide sequence with a process attached
# p<-JC69()
# s<-NucleotideSequence(string="ATGGCCA",processes=list(list(p)))
# # plot rate multipliers in range 1:4
# plotParametersAtSites(s,p,"rate.multiplier",1:4)
# # plot rate multiplier for the full sequence
# plotParametersAtSites(s,p,"rate.multiplier")
# }
#
# @author
#
# \seealso{
# Site Process Sequence
# }
#
#*/###########################################################################
setMethodS3(
"plotParametersAtSites",
class="Sequence",
function(
this,
process,
id,
index,
...
){
if(this$length == 0) {
warning("The sequence leght is zero, nothing to plot here!\n");
return(invisible(FALSE));
}
if(missing(index)) {
index<-seq(along.with=1:this$.length,by=1);
}
what<-apply(as.array(index),1,
function(pos){
tmp<-getParameterAtSites(this,process,id,pos)[[1]]$value;
if(!is.numeric(tmp)){
throw("Plot method failed becuase encountered non-numeric parameter value!\n");
}
return(tmp);
}
);
plot(
x=index,
y=what,
type="h",
lwd=1,
col="blue",
main=paste("Plot of parameter",id,"for process",process$id),
xlab="Position",
ylab="Value",
xlim=c(min(index),max(index)),
ylim=c(0,max(what)),
xaxt="n"
);
axis(side=1, at=index, labels=index);
invisible(TRUE);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setDeletionTolerance
##
###########################################################################/**
#
# @RdocMethod setDeletionTolerance
#
# @title "Set the deletion tolerance site-process specific parameter for a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# This method does some error checking and the calls \code{setParameterAtSites(this=this,process=process,id="deletion.tolerance",value=value,index=index)}.
# See \code{setParameterAtSites.Sequence} for more details.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A Process object.}
# \item{value}{A numeric vector, recycled if shorter than the index vector.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
#
# @author
#
# \seealso{
# setParameterAtSites.Sequence
# }
#
#*/###########################################################################
setMethodS3(
"setDeletionTolerance",
class="Sequence",
function(
this,
process,
value,
index,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(process)){
throw("No process given!\n");
}
else if (missing(value)){
throw("No value provided!\n");
}
else if(!inherits(process,"GeneralDeletor")){
throw("The specified process is not an insertion process!\n");
}
}
setParameterAtSites(this=this,process=process,id="deletion.tolerance",value=value,index=index);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getDeletionTolerance
##
###########################################################################/**
#
# @RdocMethod getDeletionTolerance
#
# @title "Get the deletion tolerance site-process specific parameter for a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# This method does some error checking and the calls \code{getParameterAtSites(this=this,process=process,id="deletion.tolerance",index=index)}.
# See \code{getParameterAtSites.Sequence} for more details.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A Process object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector.
# }
#
#
# @author
#
# \seealso{
# getParameterAtSites.Sequence
# }
#
#*/###########################################################################
setMethodS3(
"getDeletionTolerance",
class="Sequence",
function(
this,
process,
index,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(process)){
throw("No process given!\n");
}
if(!inherits(process,"GeneralDeletor")){
throw("The specified process is not an insertion process!\n");
}
}
rm<-getParameterAtSites(this=this,process=process,id="deletion.tolerance",index=index);
return(as.numeric(lapply(rm,function(param){param$value})));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setInsertionTolerance
##
###########################################################################/**
#
# @RdocMethod setInsertionTolerance
#
# @title "Set the insertion tolerance site-process specific parameter for a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# This method does some error checking and the calls \code{setParameterAtSites(this=this,process=process,id="insertion.tolerance",value=value,index=index)}.
# See \code{setParameterAtSites.Sequence} for more details.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A Process object.}
# \item{value}{A numeric vector, recycled if shorter than the index vector.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
#
# @author
#
# \seealso{
# setParameterAtSites.Sequence
# }
#
#*/###########################################################################
setMethodS3(
"setInsertionTolerance",
class="Sequence",
function(
this,
process,
value,
index,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(process)){
throw("No process given!\n");
}
else if (missing(value)){
throw("No value provided!\n");
}
else if(!inherits(process,"GeneralInsertor")){
throw("The specified process is not an insertion process!\n");
}
}
setParameterAtSites(this=this,process=process,id="insertion.tolerance",value=value,index=index);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getInsertionTolerance
##
###########################################################################/**
#
# @RdocMethod getInsertionTolerance
#
# @title "Get the insertion tolerance site-process specific parameter for a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# This method does some error checking and the calls \code{getParameterAtSites(this=this,process=process,id="insertion.tolerance",index=index)}.
# See \code{getParameterAtSites.Sequence} for more details.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A Process object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector.
# }
#
#
# @author
#
# \seealso{
# getParameterAtSites.Sequence
# }
#
#*/###########################################################################
setMethodS3(
"getInsertionTolerance",
class="Sequence",
function(
this,
process,
index,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(process)){
throw("No process given!\n");
}
if(!inherits(process,"GeneralInsertor")){
throw("The specified process is not an insertion process!\n");
}
}
rm<-getParameterAtSites(this=this,process=process,id="insertion.tolerance",index=index);
return(as.numeric(lapply(rm,function(param){param$value})));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: sampleStates
##
###########################################################################/**
#
# @RdocMethod sampleStates
#
# @title "Sample the states for a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# This method samples new states from the equlibrium distribution of the attched process(es) for sites
# having undefined states (NA).
# If a site has more than one substitution process attached, then the method samples the new state from the
# mixture of equlibrium distributions. The weight of each equlibrium distribution is proportional to the
# site-process specific rate multiplier of the corresponding process at the given site.
#
# Sites having defined states are not touched. All sites with undefined states must have at least one
# substitution process (object inheriting from GeneralSubstitution) attached.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
# \examples{
# # create a nucleotide sequence
# s<-NucleotideSequence(length=80)
# # create some processes
# jc69<-JC69(); # Jukes-Cantor
# hky<-HKY(base.freqs=c(0.1,0.4,0.1,0.4)) # "GC-rich" HKY
# # attach the processes
# s$processes<-list(list(jc69)) # jc is attached to all sites
# attachProcess(s,hky,60:80) # hky is attached to range 60:80
# # tweak rate multiplier for hky
# setRateMultipliers(s,hky,10,60:80)
# # set states in range 1:20
# setStates(s,"A",1:20)
# # sample remaining states
# sampleStates(s)
# # print sequence
# s
# }
#
# @author
#
# \seealso{
# sampleState.GeneralSubstitution GeneralSubstitution
# }
#
#*/###########################################################################
setMethodS3(
"sampleStates",
class="Sequence",
function(
this,
index,
...
){
if(!missing(index)){
index<-.checkIndexSanity(this, index);
}
else {
index<-seq(along.with=this$.sites);
}
for(site in this$.sites[index]){
# Sample states from the equlibrium distributions if
# the state is NA:
if(is.na(site$state)){
# Assemble the list of substitution processes:
subst.proc<-list();
for (proc in site$processes){
if(is.GeneralSubstitution(proc)){
subst.proc<-c(subst.proc, list(proc));
}
}
# Complain if we have no substitution processes to sample from:
if(length(subst.proc) == 0){
throw("Site state is NA and no substitution processes are attached. Cannot sample state!\n");
}
site.rates<-as.numeric(lapply(
subst.proc,
function(proc){
return(getParameterAtSite(proc, site,"rate.multiplier")$value);
}
));
# Normalizing site rates:
site.rates<-site.rates/sum(site.rates);
# Single subst process:
if(length(subst.proc) == 1){
site$state<-sampleState(subst.proc[[1]]);
}
else {
# Sample a substitution process according to the rate multipliers:
nproc<-sample(x=c(1:length(subst.proc)),size=1, replace=FALSE, prob=site.rates);
# Sample the state from the winner process:
site$state<-sampleState(subst.proc[[nproc]]);
}
} # if is.na...
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: clearStates
##
###########################################################################/**
#
# @RdocMethod clearStates
#
# @title "Set the states of a collection of Site objects aggregated by a Sequence object to undefined (NA)"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
# \examples{
# # create a nucleotide sequence
# s<-NucleotideSequence(string="ATGC")
# s
# # set states to NA in the range 2:3
# clearStates(s,2:3)
# s
# # set all states to NA
# clearStates(s)
# s
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"clearStates",
class="Sequence",
function(
this,
index,
...
){
if(!missing(index)){
index<-.checkIndexSanity(this, index);
}
else {
index<-seq(along.with=this$.sites);
}
for(site in this$.sites[index]){
site$.state<-NA;
site$.total.rate<-NA;
}
this$.cumulative.rate.flag<-TRUE;
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setOmegas
##
setMethodS3(
"setOmegas",
class="Sequence",
function(
this,
process,
index,
...
){
# dummy method to force the creation of the generic function
setOmegas.CodonSequence(this,process,index,...);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getOmegas
##
setMethodS3(
"getOmegas",
class="Sequence",
function(
this,
process,
index,
...
){
# dummy method to force the creation of the generic function
getOmegas.CodonSequence(this,process,index,...);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSymbolFreqs
##
###########################################################################/**
#
# @RdocMethod getSymbolFreqs
#
# @title "Get a table with the frequencies of the states of a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{index}{An integer vector specifying a set of positions. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# A table.
# }
#
# \examples{
# # create a nucleotide sequence
# s<-NucleotideSequence(length=30,processes=list(list(JC69())))
# # sample states
# sampleStates(s)
# # get state frequencies from ranges 1:10 and 20:30
# getSymbolFreqs(s,c(1:10,20:30))
# # get symbol frequencies for the full sequence
# getSymbolFreqs(s)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSymbolFreqs",
class="Sequence",
function(
this,
index,
...
){
if(!missing(index)){
index<-.checkIndexSanity(this, index);
} else {
index<-seq(along.with=this$.sites);
}
prop.table(table(as.character(lapply(this$.sites[index],getState))));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .discretizeGamma
##
setMethodS3(
".discretizeGamma",
class="Sequence",
function(
this,
shape,
ncat,
...
){
# figure out cutting points
cut<-apply(rbind(1:(ncat-1)/ncat),1, function(x){qgamma(x,shape=shape,rate=shape)})
cut<-c(0,cut,Inf);
# incomplete gamma function
Igamma<-function(x,a){
pgamma(x,shape=a, scale=1)
}
# function to calculate a category mean
cm<-function(a,b,shape,ncat){
( Igamma(b * shape, shape+1) - Igamma(a * shape,shape+1)) * ncat;
}
# calculate category means
means<-c();
for (i in 1:(length(cut)-1)){
means<-c(means,cm(cut[i], cut[i+1], shape, ncat));
}
# return a vector with the means
return(means);
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: plusGamma
##
###########################################################################/**
#
# @RdocMethod plusGamma
#
# @title "Sample the rate multiplier parameters of a Process from a Gamma distribution for a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
#
# The gamma distribution is discretized by calculating the means of the portions corresponding
# to the categories having equal probabilities. If the \code{ncat} argument is not numeric, the
# rates are sampled from the continuous gamma distribution.
# }
#
# \references{
# Yang, Z. (1994) Maximum likelihood phylogenetic estimation from DNA sequences with variable
# rates over sites: approximate methods - Journal of Molecular Evolution 39:306-314 \url{http://dx.doi.org/10.1007/BF00160154}
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A Process object.}
# \item{shape}{The shape parameter of the gamma distribution.}
# \item{index}{A vector of positions.}
# \item{ncat}{Numer of categories in the discretized gamma distribution (4 by default).}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible);
# }
#
# \examples{
# # create a sequence
# s<-NucleotideSequence(length=20)
# # attach a process
# p<-JC69()
# attachProcess(s,p)
# # get rate multipliers
# getRateMultipliers(s,p) # the default value is 1.0
# # sample rate multipliers in range 1:5 from a discrete
# #gamma distribution with shape parameter 0.5
# plusGamma(s,p,0.5,1:5)
# # get rate multipliers
# getRateMultipliers(s,p) # the default value is 1.0
# # sample rates from a continuous gamma distribution
# # with shape parameter 0.5
# plusGamma(s,p,0.5,ncat="cont")
# # get rate multipliers
# getRateMultipliers(s,p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"plusGamma",
class="Sequence",
function(
this,
process,
shape,
index,
ncat=4,
...
){
if(missing(process)){
throw("No process specified!\n");
}
else if(missing(shape)){
throw("No shape parameter specified!\n");
}
else if(!all(is.numeric(shape)) | length(shape) != 1){
throw("The shape parameter must be a numeric vector of lenght 1!\n");
}
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
if(!is.numeric(ncat)){
# continuous gamma
setParameterAtSites(this, process=process, id="rate.multiplier",value=rgamma(length(index),shape=shape,rate=shape),index=index);
}
else{
setParameterAtSites(this, process=process, id="rate.multiplier",sample(.discretizeGamma(this,shape,ncat),size=length(index),replace=TRUE),index=index);
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: plusInvGamma
##
###########################################################################/**
#
# @RdocMethod plusInvGamma
#
# @title "Sample the rate multiplier parameters of a Process from an I+Gamma distribution for a collection of Site objects aggregated by a Sequence object"
#
# \description{
# @get "title".
#
# The gamma distribution is discretized by calculating the means of the portions corresponding
# to the categories having equal probabilities. If the \code{ncat} argument is not numeric, the
# rates are sampled from the continuous gamma distribution.
# }
#
# \references{
# Gu X, Fu, YX, Li, WH (1995) Maximum likelihood estimation of the heterogeneity of substitution
# rate among nucleotide sites - Mol. Biol. Evol. 12(4):546-57 \url{http://bit.ly/aE6xF0}
#
# Yang, Z (1994) Maximum likelihood phylogenetic estimation from DNA sequences with variable
# rates over sites: approximate methods - Journal of Molecular Evolution 39:306-314 \url{http://dx.doi.org/10.1007/BF00160154}
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{process}{A Process object.}
# \item{pinv}{The proportion of invariant sites.}
# \item{shape}{The shape parameter of the gamma distribution.}
# \item{index}{A vector of positions.}
# \item{ncat}{Numer of categories in the discretized gamma distribution (4 by default).}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible);
# }
#
# \examples{
# # create a sequence
# s<-NucleotideSequence(length=20)
# # attach a process
# p<-JC69()
# attachProcess(s,p)
# # get rate multipliers
# getRateMultipliers(s,p) # the default value is 1.0
# # sample rate multipliers in range 1:5 from I+discrete Gamma
# plusInvGamma(s,p,pinv=0.5,shape=0.5,1:5)
# # get rate multipliers
# getRateMultipliers(s,p) # the default value is 1.0
# # sample rates from an I+continuos Gamma model
# plusInvGamma(s,p,pinv=0.5,shape=0.5,1:5,ncat="cont")
# # get rate multipliers
# getRateMultipliers(s,p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"plusInvGamma",
class="Sequence",
function(
this,
process,
pinv,
shape,
index,
ncat=4,
...
){
if(missing(process)){
throw("No process specified!\n");
}
else if(missing(pinv)){
throw("No proportion of invariant sites given!\n");
}
else if(!all(is.numeric(pinv)) | length(pinv) != 1){
throw("The pinv parameter must be a numeric vector of lenght 1!\n");
}
else if(pinv > 1){
throw("Tpe proportion of invariant sites cannot be larger than 1.!");
}
else if(missing(shape)){
throw("No shape parameter specified!\n");
}
else if(!all(is.numeric(shape)) | length(shape) != 1){
throw("The shape parameter must be a numeric vector of lenght 1!\n");
}
else {
if(missing(index)){
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
# discretize gamma distribution
dg<-c()
if(is.numeric(ncat)){
dg<-.discretizeGamma(this,shape,ncat);
}
# Iterating over the sites specified by the index vector:
for(site in index){
# Choose between invariant and gamma:
type<-sample(c("INV","GAMMA"),size=1, replace=FALSE, prob=c( pinv, (1-pinv) ) );
if(type == "INV"){
setParameterAtSites(this, process=process, id="rate.multiplier",value=0,index=c(site));
}
else {
if(!is.numeric(ncat)){
# continuous gamma
setParameterAtSites(this, process=process, id="rate.multiplier",value=rgamma(1,shape=shape,rate=shape),index=c(site));
}
else{
setParameterAtSites(this, process=process, id="rate.multiplier",sample(dg,size=1),index=c(site));
}
}
}
}
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: insertSequence
##
###########################################################################/**
#
# @RdocMethod insertSequence
#
# @title "Insert a Sequence object into another Sequence object after a specified position"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{The target Sequence object.}
# \item{insert}{The Sequence object to be inserted.}
# \item{position}{The position after the Sequence object will be inserted.}
# \item{process}{The Process object performing the insertion (optional).}
# \item{paranoid}{If TRUE, then the consistency of teh target objects is checked more rigurously after insertion.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
# \examples{
# # create some sequence objects.
# target<-NucleotideSequence(string="AAAAAAAAAAA")
# insert<-NucleotideSequence(string="GGGGGGGGGGG")
# # insert after position 5
# insertSequence(target,insert,5)
# # print the target sequence
# target
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"insertSequence",
class="Sequence",
function(
this,
insert,
position,
process=NA,
paranoid=FALSE,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(insert)) {
throw("Insert sequence object is missing!\n");
}
else if (missing(position)) {
throw("Insertion position is missing!\n");
}
if(!is.Sequence(insert)) {
throw("Insert object not valid!\n");
}
else if (this$length == 0 & position != 0 ) {
throw("Acceptor sequence length is zero! The only valid insertion position is 0!\n");
}
else if ( !( position >= 0 & position <=(this$.length + 1))) {
throw("Insertion position ",position," is invalid!\n");
}
}
# Just return if insert has zero length:
if(insert$length == 0){
warning("The length of the sequence to be inserted is zero! Nothing to do here!\n");
return(invisible(FALSE));
}
# Clone insert object:
insert<-clone(insert);
# Set the generator process:
if(!missing(process)) {
if( (length(process) == 0) | !is.Process(process)){
throw("Process object invalid!\n");
}
} else {
process<-Sequence$.root.ins;
}
for(site in insert$.sites) {
site$.ancestral<-process;
site$.sequence<-this;
}
# Recalculate cumulative rates if the flag is on:
if(this$.cumulative.rate.flag) {
.recalculateCumulativeRates(this);
}
# Flagging cumulative rates:
this$.cumulative.rate.flag<-TRUE;
# Inserting new site objects:
if ( position == this$.length) {
# Insertion at the end of the sequence;
this$.sites<-c(this$.sites,insert$.sites);
this$.total.rates<-c(this$.total.rates,rep(c(NA),times=insert$.length) );
this$.cumulative.rates<-c(this$.cumulative.rates,rep(NA,times=insert$.length) );
} else if (position == 0) {
# Insertion in the sequence
this$.sites<-c(insert$.sites, this$.sites);
this$.total.rates<-c(rep(NA,times=insert$.length),this$.total.rates);
this$.cumulative.rates<-c(rep(NA,times=insert$.length),this$.cumulative.rates);
} else {
# Insertion at position 0
this$.sites<-c(this$.sites[1:position],insert$.sites,this$.sites[(position+1):this$.length]);
this$.total.rates<-c(this$.total.rates[1:position],rep(NA,times=insert$.length),this$.total.rates[(position+1):this$.length]);
this$.cumulative.rates<-c(this$.cumulative.rates[1:position],rep(NA,times=insert$.length),this$.cumulative.rates[(position+1):this$.length]);
}
# Checking if lengths are consistent:
if(!exists(x="PSIM_FAST")){
if(length(this$.sites) != (this$.length + insert$.length)) {
throw("Length inconsistency after insertion!\n");
}
}
# Setting new length:
this$.length<-(this$.length + insert$.length);
# Flagging the inserted sites:
this$.flagged.sites<-c(this$.flagged.sites,(position+1):(position+insert$.length));
if(!exists(x="PSIM_FAST")){
if(length(this$.total.rates) != this$.length) {
throw("Total rates vector inconsistency after insertion!\n");
}
if(length(this$.cumulative.rates) != this$.length) {
throw("Cumulative rates vector inconsistency after insertion!\n");
}
}
# Recalculating cumulative rates:
.recalculateCumulativeRates(this);
# Paranoid check of total rates:
if(paranoid) {
for (i in 1:this$.length) {
if(this$.sites[[i]]$totalRate != this$.total.rates[[i]]) {
throw("Object total rates inconsistent with total rates vector!\n");
}
}
}
# Deleting the insert:
rm(insert);
return(invisible(this));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: deleteSubSequence
##
###########################################################################/**
#
# @RdocMethod deleteSubSequence
#
# @title "Delete a collection of sites aggregated by a Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{index}{An index vector specifying a collection of sites to be deleted. It is set to 1:seq$length if omitted.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE or errror.
# }
#
# \examples{
# # create a nucleotide sequence
# s<-NucleotideSequence(string="ATATATATATATATAT")
# # delete sites 2, 4 and 6
# deleteSubSequence(s,c(2,4,6))
# s
# # delete sites in the range 3:6
# deleteSubSequence(s,3:6)
# s
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"deleteSubSequence",
class="Sequence",
function(
this,
index,
...
){
if(length(index) == 0) {
return(FALSE);
}
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(index)) {
throw("No index vector specified!\n");
}
if(length(index) == 0) {
return(FALSE);
}
}
index<-.checkIndexSanity(this, index);
# Avoid deletion on dirty sequence as
# that will cause havoc.
if(this$.cumulative.rate.flag){
.recalculateCumulativeRates(this);
}
# Flagging cumulative rates:
this$.cumulative.rate.flag<-TRUE;
min.index<-min(index);
# Deleting site objects:
this$.sites[index]<-NULL;
# Updating rate vectors:
this$.total.rates<-this$.total.rates[-index];
this$.cumulative.rates<-this$.cumulative.rates[-index];
# Flag the site before the deletion to
# to force cumulative rate recalculation:
if (min.index > 2 ) {
this$.flagged.sites<-c(this$.flagged.sites,(min.index - 1));
}
if(!exists(x="PSIM_FAST")){
if( length(this$.sites) != (this$.length - length(index) ) ) {
throw("Inconsistency after deleting sites!\n");
}
}
this$.length<-length(this$.sites);
.recalculateCumulativeRates(this);
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: copySubSequence
##
###########################################################################/**
#
# @RdocMethod copySubSequence
#
# @title "Copy a collection of Site objects aggregated by a Sequence object into a new Sequence object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Sequence object.}
# \item{index}{An index vector specifying a collection of sites to be copied. It is set to 1:seq$length if omitted.}
# \item{process}{The Process object performing the copy (optional).}
# \item{...}{Not used.}
# }
#
# \value{
# A new Sequence object.
# }
#
# \examples{
# # create a nucleotide sequence
# s<-NucleotideSequence(string="ATATATATATATATATA")
# # copy sites in the range 3:8 in a new object
# s2<-copySubSequence(s,3:8)
# s2
# # copy sites 1,3 and 5 from s2
# s3<-copySubSequence(s2,c(1,3,5))
# s3
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"copySubSequence",
class="Sequence",
function(
this,
index,
process=NA,
...
){
if(missing(index)) {
index<-seq(along.with=this$.sites);
}
else {
index<-.checkIndexSanity(this, index);
}
if(!exists(x="PSIM_FAST")){
if(!is.na(process) & !is.Process(process)) {
throw("Process object invalid!\n");
}
}
# Avoid copying from dirty sequence:
if(this$.cumulative.rate.flag){
.recalculateCumulativeRates(this);
}
length<-length(index);
# Create an empty sequence object:
copy<-Sequence();
# Flag copy cumulative rates:
copy$.cumulative.rate.flag<-TRUE;
if(is.na(process)){
# Getting the root insertion process:
process<-Sequence$.root.ins;
}
# Setting the ancestral to sequence:
copy$.ancestral.obj<-process;
# Setting copy name:
copy$name<-paste("Copied from",this$name);
# Setting length:
copy$.length<-length;
# Clone the sites:
copy$.sites<-lapply(this$.sites[index],
function(site){
site.copy<-clone(site);
site.copy$.ancestral<-process;
return(site.copy);
}
);
# Copy total rates:
copy$.total.rates<-this$.total.rates[index];
# Create cumulative rates vector:
copy$.cumulative.rates<-cumsum(copy$.total.rates);
copy$.cumulative.rate.flag<-FALSE;
if(!exists(x="PSIM_FAST")){
if(length(copy$.sites) != length){
throw("Sites list length mismatch!\n")
}
else if(length(copy$.total.rates) != length){
throw("Total rates vector length mismatch!\n")
}
else if(length(copy$.cumulative.rates) != length){
throw("Cumulative rates vector length mismatch!\n")
}
}
return(copy);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2009 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
# @RdocClass Site
#
# @title "The Site class"
#
# \description{
#
# This is the class representing a site. Site objects can have one associated Alphabet object and one or
# more Process objects that act on their states.
# The associated Process and Site objects must have associated Alphabet objects with the same symbols set, or
# at least one of the Alphabet objects should inherit from the class AnyAlphabet.
#
# Site objects store the site-process-specific parameters of the attached Process objects.
# A site-process-specific parameter is a list containing: the identifier, the name, the value and type of the parameter.
# For example the ubiquitous rate multiplier site-process-specific parameter looks like
# \code{list(id="rate.multiplier",name="Rate multiplier",value=1,type="numeric")}.
#
# Templates for site-process-specific parameters and their default values are stored in the Process objects and
# copied into the Site object when the process is attached.
#
# Site objects have fields for associated ancestral Site objects and Sequence objects.
#
# @classhierarchy
#
# }
#
# @synopsis
#
# \arguments{
# \item{state}{A symbol belonging to the specified alphabet.}
# \item{alphabet}{An alphabet object.}
# \item{ancestral}{The ancestral Site object.}
# \item{processes}{A list of Process objects.}
# \item{sequence}{The Sequence object to which the Site object belongs.}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # create a site object
# site<-Site();
# # print the character representation (state)
# print(site);
# # get a summary
# summary(site);
# # create a site with a nucleotide alphabet
# site<-Site(state="A",alphabet=NucleotideAlphabet());
# # set site state
# site$state<-"G"
# # manipulate the associated Sequence object
# site$sequence<-Sequence()
# site$sequence
# # attach a substitution process
# site$processes<-list(JC69())
# # add one more substitution process
# attachProcess(site,K80())
# # get a list of active Event objects
# site$events
# # get a summary of the Site object
# summary(site);
# }
#
# @author
#
#
# \seealso{
# Alphabet, Process, Event
# }
#
#*/###########################################################################
setConstructorS3(
"Site",
function(
state=NA, #
alphabet=NA,
ancestral=NA,
processes=NA,
sequence=NA,
...
){
# Extend the PSRoot Class:
this<-extend(
PSRoot(),
"Site",
.state=NA,
.ancestral=NA,
.alphabet=NA,
.processes=list(),
.total.rate=NA,
.sequence=NA,
.is.site=TRUE
);
# The instance is static by default:
STATIC<-TRUE;
# Set alphabet if present:
if(!missing(alphabet)){
this$alphabet<-alphabet;
STATIC<-FALSE;
}
# Alphabet is mandatory if
# ancestral is present:
if (!missing(ancestral) & missing(alphabet) & !is.Process(ancestral)) {
throw("Ancestral object sepcified, but no alphabet is given!\n");
}
# Set ancestral pointer if present:
if(!missing(ancestral)){
# The ancestral is a site or a process:
if( !is.Process(ancestral) & !is.Site(ancestral)) {
throw("The ancestral object must be a site or a process!\n");
} else {
this$.ancestral<-ancestral;
STATIC<-FALSE;
}
}
# Set state if present,
# complain if no alphabet is specified:
if (!missing(state)) {
STATIC<-FALSE;
if(!missing(alphabet)){
this$state<-state;
} else { throw("The state is specified, but no alphabet is given!\n"); }
}
# Set the processes:
if(!missing(processes)){
this$processes<-processes;
}
# Set the parent sequence if present:
if(!missing(sequence)){
this$sequence<-sequence;
}
# Calculate total rate given the state
# and the processes:
if(!STATIC){
if(!is.na(this$.state)) {
.recalculateTotalRate(this);
}
.checkConsistency(this);
}
# Return the Site object:
return(this);
},
enforceRCC=TRUE
);
##
## Method: is.Site
##
###########################################################################/**
#
# @RdocDefault is.Site
#
# @title "Check if an object is an instance of the Site class"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
#
# # create an object
# s<-Site();
# # check whether is a Site object
# is.Site(s)
# # the same with an Event object
# is.Site(Event());
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"is.Site",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.site)){return(TRUE)}
if ( inherits(this, "Site")) {
this$.is.site<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkConsistency
##
setMethodS3(
".checkConsistency",
class="Site",
function(
this,
...
){
message<-"Site state is inconsistent! ";
# If the ancestral object is a site:
if (is.Site(this$.ancestral)) {
#Check if the alphabets match:
# Warning: using the '!='.Alphabet here!
if( this$alphabet != this$ancestral$alphabet ) {
throw(message, "The ancestral alphabet and the site alphabet is different!\n");
}
} else if (is.Process(this$.ancestral)) {
# Hook for checking the process object;
# print(this$.ancestral)
} else if (!is.na(this$.ancestral)){
throw("Ancestral object is invalid!\n");
}
# Check if the total rate is numeric or NA:
if(is.null(this$.total.rate)) {
throw("The total rate is NULL!\n");
}
if (!is.numeric(this$.total.rate) && !is.na(this$.total.rate)) {throw(message,"The total rate is not numeric!\n")}
return(invisible(TRUE));
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="Site",
function(
this,
...
){
#cat("Checking site consistency ...\n");
# Reassigning the values by virtual fields.
# The methods should complain if something is wrong.
# Slow but maybe elegant.
if(is.null(this$.alphabet)) {
throw("Site alphabet is NULL!\n");
}
else if(!is.na(this$.alphabet)) {
this$.alphabet<-this$.alphabet;
}
if(is.null(this$.ancestral)) {
throw("Ancestral object is NULL!\n");
}
if(is.null(this$.processes)) {
throw("Process list is NULL!\n");
}
else {
this$processes<-this$processes;
}
.checkConsistency(this);
lapply(
this$.processes,
function(p) {
# Even more paranoid check is possible here!
.checkSiteSpecificParamList(p$object,plist=p$site.params);
}
);
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getState
##
###########################################################################/**
#
# @RdocMethod getState
#
# @title "Get the current state of a Site object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one contaning the state (a symbol belonging to the attached Alphabet object).
# }
#
# \examples{
#
# # create a Site object with an Alphabet object attached
# s<-Site(alphabet=Alphabet(symbols=c(0,1)), state=1);
# # get current state
# getState(s)
# # get state via virtual field
# s$state
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getState",
class="Site",
function(
this,
...
){
this$.state;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setState
##
###########################################################################/**
#
# @RdocMethod setState
#
# @title "Set the state of a Site object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{new.state}{A character vector of length one, containing a symbol belonging to the attached Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns the new state (invisible).
# }
#
# \examples{
#
# # create a Site object with an Alphabet object attached
# s<-Site(alphabet=Alphabet(symbols=c(0,1)), state=1);
# # set a new state
# setState(s,"0")
# # get state via virtual field
# s$state
# # set a new state via virtual field
# s$state<-1
# s$state
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setState",
class="Site",
function(
this,
new.state,
...
){
new.state<-as.character(new.state);
if(!exists(x="PSIM_FAST")){
# Check if new.state is scalar:
if (length(new.state) != 1 ){throw("The state must be a vector of length 1!\n")}
# Check if the site has an alphabet attached:
else if(is.na(this$alphabet)) {throw("Cannot set state because the site has no alphabet attached!\n")}
# Check if symbol is in the site alphabet:
else if( !hasSymbols(this$.alphabet,new.state)) {throw("Symbol not in site alphabet!\n")}
}
this$.total.rate<-NA;
if(!is.na(this$.sequence)){
this$.sequence$.cumulative.rate.flag<-TRUE;
}
this$.state<-new.state;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAlphabet
##
###########################################################################/**
#
# @RdocMethod getAlphabet
#
# @title "Get the Alphabet object attached to a Site object"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# An Alphabet object.
# }
#
# \examples{
#
# # create a site object
# s<-Site()
# # create an Alphabet object
# a<-Alphabet(c("A","T","G"))
# # attach alphabet to site object
# setAlphabet(s,a)
# # get attached alphabet
# getAlphabet(s)
# # get attached alphabet via virtual field
# s$alphabet
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAlphabet",
class="Site",
function(
this,
...
){
this$.alphabet;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setAlphabet
##
###########################################################################/**
#
# @RdocMethod setAlphabet
#
# @title "Attach an Alphabet object to a Site object"
#
# \description{
# @get "title".
# If the ancestral site is not NA, then the symbol set of the ancestral Alphabet object and the new Alphabet
# object must be the same. The current state must be in the symbol set of the new Alphabet object, unless it is NA.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{new.alphabet}{A valid Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns the new Alphabet object (invisible).
# }
#
# \examples{
#
# # create a site object
# s<-Site()
# # create an Alphabet object
# a<-Alphabet(c("A","T","G"))
# # attach alphabet to site object
# setAlphabet(s,a)
# # set site state
# s$state<-"A"
# # clone the alphabet object
# b<-clone(a)
# # modify symbol set in b
# b$symbols<-c(b$symbols,"C")
# # attach b to s via virtual field
# s$alphabet<-b
# s$alphabet
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setAlphabet",
class="Site",
function(
this,
new.alphabet,
...
){
if(!exists(x="PSIM_FAST")){
if(!is.Alphabet(new.alphabet)){
throw("The supplied alphabet object is not valid!\n");
} else if (is.Site(this$.ancestral)) {
if (this$.ancestral$alphabet != new.alphabet) {
throw("The alphabet is not equivalent with the ancestral alphabet!\n");
}
}
else if(!is.na(this$.state) & !hasSymbols(new.alphabet, this$.state)){
throw("The current state is not part of the new alphabet!\n");
}
}
this$.total.rate<-NA;
if(!is.na(this$.sequence)){
this$.sequence$.cumulative.rate.flag<-TRUE;
}
this$.alphabet<-new.alphabet;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .setAlphabetSloppy
##
setMethodS3(
".setAlphabetSloppy",
class="Site",
function(
this,
new.alphabet,
...
){
this$.alphabet<-new.alphabet;
return(invisible(new.alphabet));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAncestral
##
###########################################################################/**
#
# @RdocMethod getAncestral
#
# @title "Get the ancestral object of a Site object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A Site object, a Process object or NA.
# }
#
# \examples{
# a<-Alphabet();
# # create some site object
# s1<-Site(alphabet=a)
# s2<-Site(ancestral=s1, alphabet=a)
# # get ancestral objects
# getAncestral(s1)
# s2$ancestral
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAncestral",
class="Site",
function(
this,
...
){
this$.ancestral;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setAncestral
##
###########################################################################/**
#
# @RdocMethod setAncestral
#
# @title "Forbidden action: setting the ancestral object for a Site object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setAncestral",
class="Site",
function(
this,
value,
...
){
throw("You should never try to modify directly the ancestral attribute!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .recalculateTotalRate
##
setMethodS3(
".recalculateTotalRate",
class="Site",
function(
this,
...
){
if(!is.na(this$.state)){
total.rate<-0;
proc<-this$.processes;
for (p in lapply(names(proc),function(id){proc[[id]][["object"]]})) {
for(e in getEventsAtSite(p, this)){
total.rate<- total.rate + e$.rate;
}
}
this$.total.rate<-total.rate
}
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getTotalRate
##
###########################################################################/**
#
# @RdocMethod getTotalRate
#
# @title "Get the total active event rate"
#
# \description{
# @get "title".
# The total rate is the sum of the rates of all active events given the current state of the Site object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A numeric vector of length one.
# }
#
# \examples{
#
# # create a nucleotide site with a JC69 substitution process attached
# s<-Site(state="A",alphabet=NucleotideAlphabet(),processes=list(JC69()))
# # get the total rate
# getTotalRate(s)
# # add a new process
# attachProcess(s,K80(rate.params=list("Alpha"=1,"Beta"=0.5)))
# # get the total rate via virtual field
# s$totalRate
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getTotalRate",
class="Site",
function(
this,
...
){
tr<-this$.total.rate;
if(is.na(tr)) {
.recalculateTotalRate(this);
return(this$.total.rate);
} else {
return(tr);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setTotalRate
##
###########################################################################/**
#
# @RdocMethod setTotalRate
#
# @title "Forbidden action: setting the total active event rate for a Site object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setTotalRate",
class="Site",
function(
this,
value,
...
){
throw("You should never try to set the totalRate directly!\n");
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: flagTotalRate
##
###########################################################################/**
#
# @RdocMethod flagTotalRate
#
# @title "Flag the total event rate"
#
# \description{
# @get "title".
# This method sets the cached total active event rate to NA, which will trigger its
# recalculation when next accessed via getTotalRate.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible NA.
# }
#
# \examples{
# # create a site object:
# p<-K80(rate.params=list("Alpha"=2,"Beta"=0.5))
# s<-Site(alphabet=NucleotideAlphabet(), state="G", processes=list(p))
# # get site rate
# s$totalRate
# # modifying site object in a dangerous way (do not do this under any circumstances!)
# s$.processes = list() # site object is now inconsistent!
# # get cached rate
# s$totalRate # incorrect value
# # flag total rate
# flagTotalRate(s)
# # get site rate
# s$totalRate # correct value
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"flagTotalRate",
class="Site",
function(
this,
...
){
# Setting .total.rate to NA,
# this will force recalculation
# when next accessed.
this$.total.rate<-NA;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEvents
##
###########################################################################/**
#
# @RdocMethod getEvents
#
# @title "Get the list of active event objects given the current state of the Site object"
#
# \description{
# @get "title".
# The list of active event object might change according to the state of the Site object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of event objects.
# }
#
# \examples{
# # create a site object with a JC69 substitution process attached
# s<-Site(alphabet=NucleotideAlphabet(), state="A",processes=list(JC69()))
# # get the list of active event objects
# getEvents(s)
# # modify site state
# s$state<-"T"
# # get the list of active event objects via virtual field
# s$events
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEvents",
class="Site",
function(
this,
...
){
procs<-lapply(names(this$.processes),function(id){this$.processes[[id]][["object"]]});
tmp<-list();
for (p in procs) {
tmp<-c(tmp,getEventsAtSite(p, this));
}
return(tmp);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
setMethodS3(
".getEventRates",
class="Site",
function(
this,
...
){
tmp<-double();
for (p in lapply(names(this$.processes),function(id){this$.processes[[id]][["object"]]})) {
for(e in getEventsAtSite(p, this)){
tmp<-c(tmp,e$.rate);
}
}
return(tmp);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setEvents
##
###########################################################################/**
#
# @RdocMethod setEvents
#
# @title "Forbidden action: setting the list of active events for a Site object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{value}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# Throws an error.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setEvents",
class="Site",
function(
this,
value,
...
){
virtualAssignmentForbidden(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getSequence
##
###########################################################################/**
#
# @RdocMethod getSequence
#
# @title "Get the Sequence object associated with a given Site object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A Sequence object or NA.
# }
#
# \examples{
# # create a site object
# s<-Site(sequence=Sequence())
# # get the associated Sequence object
# getSequence(s)
# # get the associated Sequence object via virtual field
# s$sequence
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getSequence",
class="Site",
function(
this,
...
){
this$.sequence;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setSequence
##
###########################################################################/**
#
# @RdocMethod setSequence
#
# @title "Assotiate a Sequence object with a Site object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{new.seq}{A valid Sequence object.}
# \item{...}{Not used.}
# }
#
# \value{
# The Sequence object (invisible).
# }
#
# \examples{
# # create a site object
# s<-Site()
# # get associated Sequence object
# s$sequence
# # set associated Sequence object
# setSequence(s,Sequence())
# s$sequence
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setSequence",
class="Site",
function(
this,
new.seq,
...
){
if(!exists(x="PSIM_FAST")){
if(!is.Sequence(new.seq)) {
throw("Sequence object invalid!\n");
}
}
this$.sequence<-new.seq;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: as.character
##
###########################################################################/**
#
# @RdocMethod as.character
#
# @title "Get the character representation of a Site object"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one containing the current state.
# }
#
# \examples{
# # create site object
# s<-Site(alphabet=NucleotideAlphabet(),state="A")
# # get character represenation
# x<-as.character(s)
# x
#
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"as.character",
class="Site",
function(
x,
...
){
x$.state;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary.Site
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# o<-Site()
# # get a summary
# summary(o)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="Site",
function(
object,
...
){
this<-object;
this$.summary$"State"=this$state;
if(!is.na(this$alphabet)) {
alphabet_symbols = paste(this$alphabet$symbols,collapse=" ");
this$.summary$"Alphabet"=paste("\n"," Type: ",this$alphabet$type,"\n"," Symbols: ", alphabet_symbols,sep="");
} else {
this$.summary$"Alphabet"=NA
}
attached_processes<-this$processes;
header<-paste("Attached processes (",length(attached_processes),")",sep="");
tmp<-character(0);
for (p in attached_processes) {
tmp<-paste(tmp,"\n ",p$id)
}
this$.total.rate<-NA;
if(!is.na(this$.sequence)){
this$.sequence$.cumulative.rate.flag<-TRUE;
}
this$.summary[[header]]<-tmp;
tmp<-character(0);
for (e in this$events) {
tmp<-paste(tmp,"\n ");
tmp<-paste(tmp,"Name:",e$name);
tmp<-paste(tmp," Rate:",e$rate);
tmp<-paste(tmp," Process:",e$process$id);
}
this$.summary$"Active events"<-tmp;
this$.summary$"Total rate"<-getTotalRate(this);
if(!is.na(this$sequence)){
this$.summary$"Part of sequence"<-this$sequence$id;
}
if(is.Process(this$ancestral)) {
this$.summary$"Directly inserted by"<-this$ancestral$id;
} else if (is.Site(this$ancestral)) {
this$.summary$"Ancestral state"<-this$ancestral$state;
} else if (!is.na(this$ancestral)){
throw("summary.Site detected inconsistent state!\n");
}
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: isAttached
##
###########################################################################/**
#
# @RdocMethod isAttached
#
# @title "Check whether a Process object is attached to a Site object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{process}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create a Site object
# s<-Site(alphabet=NucleotideAlphabet())
# # create a Process object
# p<-JC69()
# # check if p is attached to s
# isAttached(s,p)
# # attach p to s
# s$processes<-list(p)
# isAttached(s,p)
# }
#
# @author
#
# \seealso{
# Site Process attachProcess detachProcess getProcesses setProcesses
# }
#
#*/###########################################################################
setMethodS3(
"isAttached",
class="Site",
function(
this,
process,
...
){
if(!exists(x="PSIM_FAST")){
if (!is.Process(process)) {throw("Process object invalid!\n")}
}
attached_processes<-getProcesses(this);
if (length(attached_processes) == 0 ){ return(FALSE)}
tmp<-lapply(
attached_processes,
function(proc) { equals(proc, process)}
);
tmp<-unique(tmp);
if(length(tmp) == 1 ) {
# If we have only one process attached,
# than simply return the result of the equals() function.
return(tmp[[1]]);
} else {
# Additional check to make sure that the .process entry is here.
# if (length (intersect(class(this$.processes[[getId(process)]]),"list")) == 0) {
# throw("Something evil is happening! The process is attached, but the .process entry is invalid!\n");
# }
# If length(tmp) > 1, than one of its elements must be TRUE,
# so returning TRUE.
return(TRUE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: attachProcess
##
###########################################################################/**
#
# @RdocMethod attachProcess
#
# @title "Attach a Process object to a Site object"
#
# \description{
# @get "title".
#
# The Alphabet objects associated with the Site and Process objects must have the same symbol set, or at least one
# of them should inherit from the class AnyAlphabet.
#
# During the attachment, the site-process specific parameter templates are copied from the Process object and
# stored in the Site object.
# The Process objects are marked as write protected if the attachment was succesful.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{process}{A Process object.}
# \item{...}{Not used.}
# }
#
# \value{
# The Site object (invisible).
# }
#
# \examples{
# # create a Site object and the associated NucleotideAlphabet object
# s<-Site(alphabet=NucleotideAlphabet())
# # create a K80 substitution process
# p<-K80()
# # attach p to s
# attachProcess(s,p)
# # get the list of attached processes
# s$processes
# # check write protection for p
# p$writeProtected
# }
#
# @author
#
# \seealso{
# Site Process detachProcess setProcesses getProcesses isAttached
# }
#
#*/###########################################################################
setMethodS3(
"attachProcess",
class="Site",
function(
this,
process,
...
){
if(isAttached(this,process)) {
warning("Process already attached, doing nothing!\n");
return(invisible(this));
}
if(!exists(x="PSIM_FAST")){
if(!is.Process(process)) {
throw("Process object is not valid!\n"); }
else if( is.na(process$alphabet) ){
throw("The process has no alphabet attached!\n"); }
else if( is.na(this$alphabet) ){
throw("The site has no alphabet attached!\n"); }
else if (this$alphabet != process$alphabet) {
throw("The site and process alphabets are incompatible!\n");
}
else if( hasUndefinedRate(process) ){
warning("The process",process$id," has undefined rates!\n");
}
}
this$.processes[[process$id]]<-list (
object = process,
# We copy the default site-process specific parameters
# from the process object.
site.params = process$siteSpecificParamList
);
this$.total.rate<-NA;
if(!is.na(this$.sequence)){
this$.sequence$.cumulative.rate.flag<-TRUE;
}
# The user should not modify the process
# after is attached to a site!
process$writeProtected<-TRUE;
invisible(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .attachProcessSloppy
##
setMethodS3(
".attachProcessSloppy",
class="Site",
function(
this,
process,
...
){
if(isAttached(this,process)) {
warning("Process already attached, doing nothing!\n");
return(invisible(this)); }
else {
this$.processes[[process$id]]<-list (
object = process,
# We copy the default site-process specific parameters
# from the process object.
site.params = process$siteSpecificParamList
);
}
this$.total.rate<-NA;
if(!is.na(this$.sequence)){
this$.sequence$.cumulative.rate.flag<-TRUE;
}
# The user should not modify the process
# after is attached to a site!
process$writeProtected<-TRUE;
invisible(this);
},
private=TRUE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: detachProcess
##
###########################################################################/**
#
# @RdocMethod detachProcess
#
# @title "Site"
#
# \description{
# @get "title".
# The site-process specific parameters stored in the Site object and belonging to the detached Process objects will be destroyed.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object}
# \item{process}{A Process object}
# \item{...}{Not used.}
# }
#
# \value{
# The Site object (invisible).
# }
#
# \examples{
# # create a Site objects and attach some processes
# s<-Site()
# s$alphabet<-NucleotideAlphabet()
# p1<-JC69(); p2<-K80()
# attachProcess(s,p1)
# attachProcess(s,p2)
# # get the list of attached processes
# s$processes
# # detach p1
# detachProcess(s,p1)
# s$processes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"detachProcess",
class="Site",
function(
this,
process,
...
){
if(!exists(x="PSIM_FAST")){
if(!is.Process(process)) {
throw("Process object is not valid!\n");
}
}
else if (!isAttached(this,process)) {
warning("Process is not attached, doing nothing!\n");
}
# Setting the list entry to NULL,
# so it will wanish from the list.
this$.processes[[process$id]]<-NULL;
this$.total.rate<-NA;
if(!is.na(this$.sequence)){
this$.sequence$.cumulative.rate.flag<-TRUE;
}
invisible(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setProcesses
##
###########################################################################/**
#
# @RdocMethod getProcesses
#
# @title "Get the list of Process objects attached to a Site object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of Process objects.
# }
#
# \examples{
# # create a Site object with some processes attached
# s<-Site(alphabet=NucleotideAlphabet(),processes=list(K80(),JC69()))
# # get list of attached Process objects
# getProcesses(s)
# # get list of attached Process objects via virtual field
# s$processes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getProcesses",
class="Site",
function(
this,
...
){
lapply(names(this$.processes),function(id){this$.processes[[id]][["object"]]});
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setProcesses
##
###########################################################################/**
#
# @RdocMethod setProcesses
#
# @title "Specify the list of Process objects attached to a Site object"
#
# \description{
# @get "title".
# The Process objects in the "value" list correspond to the set of processes to be attached to the Site object.
# Process objects already attached to a given Site are skipped. Attached processes which are not memebers of the list
# are detached, so specifying an empty list will detach all processes.
#
# This method is an alternative to \code{attachProcess.Site} and \code{detachProcess.Site}, working with
# more than one process object.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A Site object.}
# \item{value}{A list of valid Process objects.}
# \item{...}{Not used.}
# }
#
# \value{
# The Site object (invisible).
# }
#
# \examples{
# # create a Site object
# s<-Site(alphabet=NucleotideAlphabet())
# # create some processes
# p1<-JC69(); p2<-K80(); p3<-DiscreteInsertor(rate=1);
# # attach the processes
# setProcesses(s,list(p1,p2,p3))
# # attach one more process via virtual field
# s$processes<-c(s$processes,list(GTR()))
# # get the list of attached processes
# s$processes
# # detach all processes via virtual field
# s$processes<-list()
# s$processes
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setProcesses",
class="Site",
function(
this,
value,
...
){
if(missing(value)) {throw("No new value given!\n")}
value<-as.list(value);
# All the top-level elements must be Process instances!
for(i in value) {
if(!is.Process(i)){
throw("The accepted argument is a list of processes!\nVectors and lists are not euivalent, take care!\n");
}
}
attached<-getProcesses(this);
# Sadly we cannot use set operations directly here
# beacuse we lose the object references.
to.attach<-list();
to.detach<-list();
the.rest<-list();
for (i in value) {
if (!isAttached(this,i)) {
to.attach<-c(to.attach,list(i));
} else {
the.rest<-c(the.rest,list(i));
}
}
for (i in attached) {
in.the.rest<-FALSE;
for (j in the.rest) {
if (i == j) {
in.the.rest<-TRUE;
break;
}
} # /for j
if(!in.the.rest) {
to.detach<-c(to.detach,list(i));
}
} # /for i
lapply(to.detach, function(process) {detachProcess(this,process)});
lapply(to.attach, function(process) {attachProcess(this,process)});
invisible(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .setProcessesSloppy
##
setMethodS3(
".setProcessesSloppy",
class="Site",
function(
this,
value,
...
){
value<-as.list(value);
# All the top-level elements must be Process instances!
attached<-getProcesses(this);
# Sadly we cannot use set operations directly here
# beacuse we lose the object references.
to.attach<-list();
to.detach<-list();
the.rest<-list();
for (i in value) {
if (!isAttached(this,i)) {
to.attach<-c(to.attach,list(i));
} else {
the.rest<-c(the.rest,list(i));
}
}
for (i in attached) {
in.the.rest<-FALSE;
for (j in the.rest) {
if (i == j) {
in.the.rest<-TRUE;
break;
}
} # /for j
if(!in.the.rest) {
to.detach<-c(to.detach,list(i));
}
} # /for i
lapply(to.detach, function(process) {detachProcess(this,process)});
lapply(to.attach, function(process) {.attachProcessSloppy(this,process)});
invisible(this);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Copyright 2014 Botond Sipos
## See the package description for licensing information.
##
##########################################################################/**
#
# @RdocClass ToleranceSubstitution
#
# @title "The ToleranceSubstitution class"
#
# \description{
# This a class representing a continuous-time Markov process acting
# on the state space defined by the symbols stored in the Alphabet object
# passed to the object constructor.
#
# In contrast to GeneralSubstitution, the ToleranceSubstitution class has a site-specific
# substitution tolerance parameter ("substitution.tolerance") which determines the probability of
# accepting the proposed events. As a consequence, the branch lengths inferred from
# the simulated data will no longer correspond to the neutral expectations unless
# all tolerance values are equal to 1.
#
# @classhierarchy
# }
#
# @synopsis
#
# \arguments{
# \item{name}{The name of the object.}
# \item{alphabet}{The alphabet on which the process acts (Alphabet object).}
# \item{rate.list}{A list with the substitution rates. It will be passed to \code{setRateList} method.}
# \item{equ.dist}{The equilibrium distribution (see \code{setEquDist.ToleranceSubstitution}).}
# \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
# @allmethods
# }
#
# \examples{
# # construct a GTR process object, we will use this to fill in the rates
# # for the ToleranceSubstitution process.
# gtr <- GTR(
# name="MyGTR",
# rate.params=list(
# "a"=1, "b"=2, "c"=3,
# "d"=1, "e"=2, "f"=3
# ),
# base.freqs=c(2,2,1,1)/6
# )
# rate.list.gtr <- gtr$rateList
#
# # Construct the ToleranceSubstitution process.
# p <- ToleranceSubstitution(
# name = "MyTolSubst",
# alphabet = NucleotideAlphabet(),
# rate.list = rate.list.gtr,
# )
#
# plot(p)
#
# # construct root sequence object
# s<-NucleotideSequence(length=20)
#
# # attach process
# attachProcess(s,p)
#
# # sample states from the equilibrium
# # distribution of the attached processes
# sampleStates(s)
#
# ## Set the substitution tolerance parameters for some sites:
# setParameterAtSites(s, p, "substitution.tolerance",c(0,0.05,0.1),1:3)
#
# ## Plot the substitution tolerance parameters across sites:
# plotParametersAtSites(s,p,"substitution.tolerance")
#
# # Construct simulation object:
# sim <-PhyloSim(root.seq=s, phylo=rtree(3))
#
# # Run simulation:
# Simulate(sim)
#
# # Plot alignment:
# plot(sim)
#
# }
#
# @author
#
# \seealso{
# Process QMatrix Event Site GeneralIndel GTR WAG
# }
#
#*/###########################################################################
setConstructorS3(
"ToleranceSubstitution",
function(
name="Anonymous",
alphabet=NA,
rate.list=NA,
equ.dist=NA,
...
) {
# Set an empty alphabet by default
# to satisfy the static instance:
if(missing(alphabet)){
alphabet<-Alphabet(name="Undefined");
}
this<-Process(
name=name,
alphabet=alphabet
);
this<-extend(
this,
"ToleranceSubstitution",
.q.matrix=NA,
.equ.dist=NA,
.handler.template=NA,
.is.general.substitution=TRUE
);
# Adding insertion tolerance parameter.
.addSiteSpecificParameter(
this,
id="substitution.tolerance",
name="Substitution tolerance parameter",
value=as.double(1), # Accept all by default
type="numeric"
);
# Accept/reject substitution events based on the site specific tolerance parameter:
this$.accept.by <- function(process=NA, site=NA){
accept.prob<-getParameterAtSite(process, site, "substitution.tolerance")$value;
# Accept/reject:
return( sample(c(TRUE,FALSE),replace=FALSE,prob=c(accept.prob,(1-accept.prob)),size=1) );
}
###
# Initialize with NA-s equDist:
if (missing(equ.dist)){
.initEquDist(this);
} else {
# or set if we have one:
this$equDist<-equ.dist;
}
# Create the QMatrix object:
qm<-QMatrix(name=name, alphabet=alphabet);
# Set the rates:
if(!missing(rate.list)){
qm$rateList<-rate.list;
}
# Attach the QMatrix to the process:
this$.q.matrix<-qm;
this$.q.matrix$process<-this;
# Try to guess the equlibrium distribution:
if (missing(equ.dist) & !missing(rate.list)){
if(.setEquDistFromGuess(this)){
# and perfrom rescaling if suceeded:
rescaleQMatrix(this);
}
}
# Using virtual field to clear Id cache:
this$name<-name;
# Set the template for handling substitution events:
this$.handler.template<-function(event=NA){
accepted <- FALSE
if(this$.accept.by(event$.process, event$.site)){
# Just set the new state base on the event name.
# The name *should* be valid and correct, so no more checking is needed.
setState(event$.site, strsplit(event$.name,split="->",fixed=TRUE)[[1]][[2]]);
# Mark the event as accepted:
accepted <- TRUE
}
# Return details:
return(
list(
type = "substitution",
accepted = accepted
)
);
}
return(this);
},
enforceRCC=TRUE
);
##
## Method: checkConsistency
##
###########################################################################/**
#
# @RdocMethod checkConsistency
#
# @title "Check object consistency"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
#
# \value{
# Returns an invisible TRUE if no inconsistencies found in the object, throws
# an error otherwise.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"checkConsistency",
class="ToleranceSubstitution",
function(
this,
...
){
wp<-this$writeProtected;
if (wp) {
this$writeProtected<-FALSE;
}
may.fail<-function(this) {
# The process must have a valid alphabet object:
if(!is.Alphabet(this$.alphabet)){
throw("Alphabet object is invalid!\n");
}
# Name:
if(!is.na(this$name)){
this$name<-this$name;
}
# EquDist:
if(!any(is.na(this$.equ.dist))){
this$equDist<-this$equDist;
}
# Negative rates are impossible:
if(all(!is.na(this$rateList)) & any(as.numeric(this$rateList) < 0 )){
throw("The rate matrix has negative off-diagonal elements!\n");
}
# QMatrix should never be NA!
this$QMatrix<-this$QMatrix;
# Further checks if survived the one above:
checkConsistency(this$.q.matrix,check.process=FALSE);
if(is.Process(this$.q.matrix$.process)){
# Check for alphabet compatibility:
if(this$.alphabet != this$.q.matrix$.process$alphabet){
throw("Process/QMatrix alphabet mismatch!\n");
}
# Check if the parent process QMatrix is this object:
if(!equals(this$.q.matrix$.process, this) ){
throw("QMatrix process is not identical with self!\n");
}
} else if(!is.na(this$.q.matrix$.process)){
throw("QMatrix process entry is invalid!\n");
}
}
tryCatch(may.fail(this),finally=this$writeProtected<-wp);
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventsAtSite
##
###########################################################################/**
#
# @RdocMethod getEventsAtSite
#
# @title "Generate the list of active Event objects for a given attached Site object"
#
# \description{
# @get "title".
#
# This is the single most important method in the \code{ToleranceSubstitution} class. It generates a list of the active
# Event objects given the transition rate matrix (Q matrix) and the "rate.multiplier" Site-Process specific parameter.
# It returns an empty list if the state of the site is "NA".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{target.site}{A Site object. The ToleranceSubstitution object must be attached to the Site object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of the active Event objects.
# }
#
# \examples{
# # create an Alphabet object
# a<-BinaryAlphabet()
# # create a Site object
# s<-Site(alphabet=a);
# # create a ToleranceSubstitution object
# p<-ToleranceSubstitution(alphabet=a,rate.list=list("0->1"=1,"1->0"=1))
# # attach process p to site object s
# attachProcess(s,p)
# # get the rate of active events
# getEventsAtSite(p,s) # empty list
# # set the state of s
# s$state<-1;
# # get the rate of active events
# getEventsAtSite(p,s)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEventsAtSite",
class="ToleranceSubstitution",
function(
this,
target.site,
...
){
# The main method of this class,
# generating a list of event objects given the
# state of the target site.
if(!exists(x="PSIM_FAST")){
if(missing(target.site)) {
throw("No target site provided!\n");
}
}
# The following code is commented out to
# increase speed
#else if (!sloppy) {
# Additional checks. They can be
# disabled by sloppy=TRUE
#if(!is.Site(target.site)) {
# throw("Target site invalid!\n");
#}
#else if(!is.QMatrix(this$.q.matrix)){
# throw("Cannot provide event objects because the rate matrix is not set!\n");
#}
#else if(!is.numeric(this$.equ.dist)){
# throw("Cannot provide event objects because the equilibrium frequencies are not defined!\n");
#}
#}
state<-as.character(target.site$.state);
# Just return an empty list if the state is NA:
if(is.na(state)){
return(list());
}
# The rate of the event is the product of the general rate and the
# site specific rate multiplier:
rate.multiplier<-target.site$.processes[[this$.id]]$site.params[["rate.multiplier"]]$value;
# Return empty list if the rate multiplier is zero.
if(rate.multiplier == 0 ) {
return(list());
}
# Get rate matrix:
rate.matrix<-this$.q.matrix$.rate.matrix;
symbols<-this$.alphabet$.symbols;
rest<-symbols[ which(symbols != state) ];
# Create the event objects:
events<-list();
for(new.state in rest){
name<-paste(state,new.state,sep="->");
# Clone the event template object:
event<-clone(this$.event.template);
# Set event name:
event$.name<-name;
# Set the generator process:
event$.process<-this;
# Set the target position passed in a temporary field,
# Event objects are not aware of their posiitions in general!
event$.position<-target.site$.position;
# Set the target site:
event$.site<-target.site;
# Set the event rate:
event$.rate<-(rate.multiplier * (rate.matrix[state,new.state]));
# Set the handler for the substitution event:
event$.handler<-this$.handler.template;
# Add to events list:
events<-c(events, list(event));
}
return(events);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setEquDist
##
###########################################################################/**
#
# @RdocMethod setEquDist
#
# @title "Set the equilibrium distribution for a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# In the case the equlibrium distribution cannot be guessed from the rate matrix one should provide
# a valid equilibrium distribution. The equilibrium distribution must be compatible with the rate matrix.
# The provided numeric vector will be resacled in the case the sum of the elemnts is not one.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{value}{A numeric vector containing the equlibrium symbol frequencies. The order of the frequencies must be the same as in the symbol vector of the attached Alphabet object.}
# \item{force}{Do not check compatibility with thr rate matrix.}
# \item{silent}{Do not print out warnings.}
# \item{...}{Not used.}
# }
#
# \value{
# The new equlibrium distribution (invisible).
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(
# alphabet=BinaryAlphabet(),
# rate.list=list("1->0"=1,"0->1"=1)
# )
# # get equlibrium distribution
# getEquDist(p)
# # get equilibrium distribution via virtual field
# p$equDist
# # re-set the equilibrium distribution
# dist<-p$equDist * 3
# dist
# setEquDist(p,dist)
# p$equDist
# # re-set equilibrium distribution via virtual field
# p$equDist<-p$equDist * 2
# p$equDist
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setEquDist",
class="ToleranceSubstitution",
function(
this,
value,
force=FALSE,
silent=FALSE,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(!is.Alphabet(this$alphabet)){
throw("Cannot set equilibrium distribution because the alphabet is undefined!");
}
if(missing(value)) {
throw("No new value provided!\n");}
else if(!is.numeric(value)) {
throw("The new value must be numeric!\n");
}
}
if(length(value) != this$alphabet$size){
throw("The new value must be a vector of length ",this$alphabet$size,"!\n");
}
if(!PSRoot$my.all.equal(sum(value), 1.0)) {
value<-(value/sum(value));
if (silent == FALSE){
warning("The provided probabilities have been rescaled in order to sum to one!\n");
}
}
if(!exists(x="PSIM_FAST")){
# Check if the provided equlibrium distribution is
# compatible with the rate matrix:
if( !.checkEquMatCompat(this, rbind(value)) & force==FALSE){
throw("The provided equlibrium distribution: ",paste(value,collapse=" ")," is not compatible with the rate matrix! Use force=TRUE to set it anyway!\n");
}
}
# Set the value:
this$.equ.dist<-rbind(value);
# Set dimnames:
colnames(this$.equ.dist)<-(this$alphabet$symbols);
rownames(this$.equ.dist)<-c("Prob:");
return(invisible(this$.equ.dist));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .setEquDistFromGuess
##
setMethodS3(
".setEquDistFromGuess",
class="ToleranceSubstitution",
function(
this,
...
){
# Try to guess equlibrium distribution:
tmp<-.guessEquDist(this);
# Take care with the condition here!
# We can get in trouble with any()
# if the first value is zero!
if( length(tmp) == 1 & all(tmp == FALSE) ){
warning("The equlibrium distribution of the substitution process could not be determined based on the rate matrix!\n You have to set yourself the proper distribution in order to use the process!");
return(FALSE);
}
else {
this$equDist<-tmp;
return(TRUE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .checkEquMatCompat
##
setMethodS3(
".checkEquMatCompat",
class="ToleranceSubstitution",
function(
this,
value,
...
){
if(missing(value)) {
throw("No equlibrium distribution provided!\n")
}
else if ( length(value) != dim(this$.q.matrix$.orig.matrix)[[2]] ){
throw("Value vector length should be",dim(this$.q.matrix$.orig.matrix)[[2]],"!\n");
}
else {
# The following matrix product of the equlibrium distribution
# and the rate matrix should give the zero vector:
tmp<-(rbind(value) %*% as.matrix(this$.q.matrix$.orig.matrix));
if(PSRoot$my.all.equal(tmp, rep(0.0, times=length(tmp))) ){
return(invisible(TRUE));
} else {
return(FALSE);
}
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .guessEquDist
##
setMethodS3(
".guessEquDist",
class="ToleranceSubstitution",
function(
this,
...
){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot guess equilibrium distribution because the Q matrix is not set!\n");
}
# Refuse to guess if the rate matrix has zero entries:
if(length(which(this$.q.matrix$.orig.matrix == 0)) != 0 ){
warning("Cannot guess equilibrium distribution because the rate matrix has zero entries!\n");
return(FALSE);
}
# Get the left eigenvalues and eigenvectors of the rate matrix:
eigen<-eigen(t(this$.q.matrix$.orig.matrix));
dist<-numeric(0);
if( length(intersect(is.complex(eigen$values),TRUE)) == 0 ) {
# if all eigenvalues are real:
# Choose the largest eigenvalue (which should be zero):
index<-which( eigen$values == max(eigen$values));
# Choose the correspondign eigenvector:
dist<-rbind(eigen$vectors[ ,index]);
}
else {
# If we have complex eigenvalues:
# Choose the eigenvalue (l) with maximum |e^(l)|
tmp<-abs(exp(eigen$values));
index<-which(tmp == max(tmp));
# ... and the corresponding eigenvector:
dist<-as.double(eigen$vectors[,index]);
}
# Normalize the eigenvector:
return(dist/sum(dist));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: .initEquDist
##
setMethodS3(
".initEquDist",
class="ToleranceSubstitution",
function(
this,
dummy=NA, # to satisfy method classification
...
){
if(!isEmpty(this$.alphabet)){
# Fill in with NA-s
this$.equ.dist<-rbind(rep(NA,times=this$.alphabet$size));
# Set the dimnames:
colnames(this$.equ.dist)<-this$.alphabet$symbols;
rownames(this$.equ.dist)<-c("Prob:");
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEquDist
##
###########################################################################/**
#
# @RdocMethod getEquDist
#
# @title "Get the equilibrium distribution from a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{dummy}{Not used.}
# \item{...}{Not used.}
# }
#
# \value{
# The new equlibrium distribution (invisible).
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(
# alphabet=BinaryAlphabet(),
# rate.list=list("1->0"=1,"0->1"=1)
# )
# # get equlibrium distribution
# getEquDist(p)
# # get equilibrium distribution via virtual field
# p$equDist
# # re-set the equilibrium distribution
# dist<-p$equDist * 3
# dist
# setEquDist(p,dist)
# p$equDist
# # re-set equilibrium distribution via virtual field
# p$equDist<-p$equDist * 2
# p$equDist
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEquDist",
class="ToleranceSubstitution",
function(
this,
dummy=NA, # to satisfy method classification
...
){
this$.equ.dist;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: sampleState
##
###########################################################################/**
#
# @RdocMethod sampleState
#
# @title "Sample a state from the equlibrium distribution of a ToleranceSubstitution object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # get equlibrium distribution
# getEquDist(p)
# # get equilibrium distribution via virtual field
# p$equDist
# # sample from equilibrium distribution
# sampleState(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"sampleState",
class="ToleranceSubstitution",
function(
this,
...
){
if(!exists(x="PSIM_FAST")){
if(any(is.na(this$.equ.dist))){
throw("Cannot sample state because the equlibrium distribution is not defined!\n");
}
else if (!is.Alphabet(this$.alphabet)){
throw("Cannot sample state because the alphabet is not valid! That is strange as equlibrium distribution is defined!\n");
}
}
if(this$.alphabet$size == 0){
throw("The process alphabet is empty, nothing to sample here!\n");
}
if(this$.alphabet$size == 1){
# Special case: single letter in the alphabet:
return(this$.alphabet$symbols[[1]]);
}
else {
# Sample from the equlibrium distribution:
sample(x=this$.alphabet$.symbols, size=1, replace=FALSE, prob=this$.equ.dist);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getQMatrix
##
###########################################################################/**
#
# @RdocMethod getQMatrix
#
# @title "Get the QMatrix object aggregated by a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# This method is mostly used internally.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# A QMatrix object.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # get the QMatrix object
# getQMatrix(p)
# # get the QMatrix object via virtual field
# q<-p$qMatrix
# # tweak with the QMatrix
# setRate(q,"0->1",2)
# # set a new QMatrix for p
# setQMatrix(p,q)
# summary(p)
# # set new QMatrix via virtual field
# setRate(q,"1->0",2)
# p$qMatrix<-q
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getQMatrix",
class="ToleranceSubstitution",
function(
this,
...
){
this$.q.matrix;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setQMatrix
##
###########################################################################/**
#
# @RdocMethod setQMatrix
#
# @title "Set the QMatrix object aggregated by a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# This method is mostly used internally.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{value}{A QMatrix object.}
# \item{...}{Not used.}
# }
#
# \value{
# The QMatrix object.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # get the QMatrix object
# getQMatrix(p)
# # get the QMatrix object via virtual field
# q<-p$qMatrix
# # tweak with the QMatrix
# setRate(q,"0->1",2)
# # set a new QMatrix for p
# setQMatrix(p,q)
# summary(p)
# # set new QMatrix via virtual field
# setRate(q,"1->0",2)
# p$qMatrix<-q
# summary(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setQMatrix",
class="ToleranceSubstitution",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)){
throw("No new value provided!\n");
}
else if(!is.QMatrix(value)){
throw("The provided object is not a QMatrix!\n");
}
else if (!is.Alphabet(getAlphabet(this))){
throw("Cannot set QMatrix because process alphabet is not defined!\n");
}
else if(!is.Alphabet(value$alphabet)){
throw("Cannot set QMatrix because the alphabet of the provided QMatrix object is not set!\n");
}
else if(getAlphabet(this) != value$alphabet){
throw("Alphabet mismatch! Cannot set QMatrix!\n");
}
}
this$.q.matrix<-value;
return(this$.q.matrix)
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setAlphabet
##
###########################################################################/**
#
# @RdocMethod setAlphabet
#
# @title "Set the Alphabet object aggregated by a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# This method also sets the alphabet for the associated QMatrix object, which will set all rates to NA.
# This method will also re-initialize the equlibrium distribution by setting all frequencies to NA.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{value}{An Alphabet object.}
# \item{...}{Not used.}
# }
#
# \value{
# The Alphabet object.
# }
#
# \examples{
# # create a ToleranceSubstitution object with an attached BinaryAlphabet object
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet())
# # get object summary
# summary(p)
# # get alphabet
# getAlphabet(p)
# # get alphabet via virtual field
# p$alphabet
# # set a new alphabet
# setAlphabet(p,NucleotideAlphabet())
# summary(p)
# # set alphabet via virtual field
# p$alphabet<-BinaryAlphabet()
# p$alphabet
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setAlphabet",
class="ToleranceSubstitution",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(missing(value)){
throw("No new value provided!\n");
}
else if (!is.Alphabet(value)){
throw("Alphabet object is invalid!\n");
}
}
this$.alphabet<-value;
# Set the QMatrix alphabet
if(is.QMatrix(this$.q.matrix)){
setAlphabet(this$.q.matrix, value);
}
.initEquDist(this);
return(this$.alphabet);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getAlphabet
##
###########################################################################/**
#
# @RdocMethod getAlphabet
#
# @title "Get the Alphabet object aggregated by a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# This method also sets the alphabet for the associated QMatrix object, which will set all rates to NA.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# An Alphabet object.
# }
#
# \examples{
# # create a ToleranceSubstitution object with an attached BinaryAlphabet object
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet())
# # get object summary
# summary(p)
# # get alphabet
# getAlphabet(p)
# # get alphabet via virtual field
# p$alphabet
# # set a new alphabet
# setAlphabet(p,NucleotideAlphabet())
# summary(p)
# # set alphabet via virtual field
# p$alphabet<-BinaryAlphabet()
# p$alphabet
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getAlphabet",
class="ToleranceSubstitution",
function(
this,
...
){
# Just to satisfy method classification:
this$.alphabet;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: hasUndefinedRate
##
###########################################################################/**
#
# @RdocMethod hasUndefinedRate
#
# @title "Check if a ToleranceSubstitution object has undefined rates"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet())
# # check if it has undefined rates
# hasUndefinedRate(p) # TRUE
# # set the missing rates
# p$rateList<-list("0->1"=1,"1->0"=2)
# # check for undefined rates again
# hasUndefinedRate(p) # FALSE
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"hasUndefinedRate",
class="ToleranceSubstitution",
function(
this,
...
){
if( any(is.na(this$.q.matrix$.orig.matrix)) | any(is.na(this$.q.matrix$.rate.matrix))){
return(TRUE);
}
else {
return(FALSE);
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventRate
##
###########################################################################/**
#
# @RdocMethod getEventRate
#
# @title "Get the scaled rate of an event from a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# This method return the element from the scaled rate matrix stored in the associated QMatrix object corresponding to
# a given event. The event can be specified by the inital and target states ("from" and "to" arguments), or by the
# event name ("from->to"). The event name takes precedence over the "from" and "to" arguments.
#
# This method doesn't take into account the site specific rate multipliers in any way.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{name}{The name of the event.}
# \item{from}{The initial state.}
# \item{to}{Target state.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # get the scaled rate of "0->1" by name
# getEventRate(p,"0->1")
# # get the scaled rate of "0->1" by states
# getEventRate(p,from="0",to="1")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEventRate",
class="ToleranceSubstitution",
function(
this,
name=NA,
from=NA,
to=NA,
...
){
# For getting the scaled event rate:
if(!exists(x="PSIM_FAST")){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot get rate as the rate matrix is undefined!\n");
}
}
else if(!missing(name) & missing(from) & missing(to)){
return(getEventRate(this$.q.matrix, name=name));
}
else if (missing(name) & !missing(from) & !missing(to)){
return(getEventRate(this$.q.matrix, from=from, to=to));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getEventRateAtSite
##
###########################################################################/**
#
# @RdocMethod getEventRateAtSite
#
# @title "Get the site spcific rate of an event from a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# This method return the element from the associated QMatrix object corresponding to
# a given event multiplied by the "rate.multiplier" site-process specific parameter stored in the specified site object.
# The event can be specified by the inital and target states ("from" and "to" arguments), or by the
# event name ("from->to"). The event name takes precedence over the "from" and "to" arguments.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object. It must be attached to the provided Site object.}
# \item{site}{A Site object.}
# \item{name}{The name of the event.}
# \item{from}{The initial state.}
# \item{to}{Target state.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # create a Site object
# s<-Site(alphabet=BinaryAlphabet())
# # attach process p to site s
# s$processes<-list(p)
# # set the rate multiplier for s and p
# setParameterAtSite(p,s,id="rate.multiplier",value=2)
# # get the site specific rate of "0->1" by name
# getEventRateAtSite(p,s,"0->1")
# # get the site specific rate of "0->1" by states
# getEventRateAtSite(p,s,from="0",to="1")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getEventRateAtSite",
class="ToleranceSubstitution",
function(
this,
site,
name=NA,
from=NA,
to=NA,
...
){
if(!exists(x="PSIM_FAST")){
if(missing(site)){
throw("No site provided");
}
else if (!isAttached(site, process=this)){
throw("The process is not attached to the specified site!\n");
}
}
global.rate<-numeric();
# Event specified by name:
if(!missing(name) & missing(from) & missing(to)){
global.rate<-getEventRate(this$.q.matrix, name=name);
}
# Event specified by from= and to=
else if(missing(name) & !missing(from) & !missing(to)){
global.rate<-getEventRate(this$.q.matrix, from=from, to=to);
}
else {
throw("The substitution should be specified by name or by the \"from\" and \"to\" arguments!\n");
}
return(global.rate * site$.processes[[this$.id]]$site.params[["rate.multiplier"]]$value );
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRate
##
###########################################################################/**
#
# @RdocMethod getRate
#
# @title "Get an unscaled rate of an event from a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# This method gets the element corresponding to a given event form the unscaled Q matrix.
# a given event. The event can be specified by the inital and target states ("from" and "to" arguments), or by the
# event name ("from->to"). The event name takes precedence over the "from" and "to" arguments.
#
# The rescaled rates (used during simulations) are returned by the \code{getEventRate} method.
#
# This method doesn't take into account the site specific rate multipliers in any way.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{name}{The name of the event.}
# \item{from}{The initial state.}
# \item{to}{Target state.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # get the unscaled rate of "0->1" by name
# getRate(p,"0->1")
# # get the unscaled rate of "0->1" by states
# getRate(p,from="0",to="1")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRate",
class="ToleranceSubstitution",
function(
this,
name=NA,
from=NA,
to=NA,
...
){
if(!exists(x="PSIM_FAST")){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot get rate as the rate matrix is undefined!\n");
}
}
if(!missing(name) & missing(from) & missing(to)){
return(getRate(this$.q.matrix, name=name));
}
else if (missing(name) & !missing(from) & !missing(to)){
return(getRate(this$.q.matrix, from=from, to=to));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRate
##
###########################################################################/**
#
# @RdocMethod setRate
#
# @title "Set an unscaled rate for an event from a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# This method sets the element corresponding to a given event in the unscaled Q matrix.
# The event can be specified by the inital and target states ("from" and "to" arguments), or by the
# event name ("from->to"). The event name takes precedence over the "from" and "to" arguments.
#
# Modifying any rate in the unscaled Q matrix will trigger the re-scaling of the whole matrix.
# The rescaled rates (used during simulations) are returned by the \code{getEventRate} method.
#
# This method doesn't modify the site specific rate multipliers.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{name}{The name of the event.}
# \item{from}{The initial state.}
# \item{value}{The new value of the rate.}
# \item{to}{Target state.}
# \item{...}{Not used.}
# }
#
# \value{
# A Numeric vector of length one.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=1))
# # set the unscaled rate by event name
# setRate(p,"0->1",2)
# # get the unscaled rate of "0->1" by name
# getRate(p,"0->1")
# # set the unscaled rate by states
# setRate(p,"0->1",0.5)
# # get the unscaled rate of "0->1" by states
# getRate(p,from="0",to="1")
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRate",
class="ToleranceSubstitution",
function(
this,
name=NA,
value,
from=NA,
to=NA,
...
){
.checkWriteProtection(this);
# Setting unscaled rate:
if(!exists(x="PSIM_FAST")){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot set rate as the rate matrix is undefined!\n");
}
}
if(!missing(name) & missing(from) & missing(to)){
return(setRate(this$.q.matrix, name=name, value=value));
}
else if (missing(name) & !missing(from) & !missing(to)){
return(setRate(this$.q.matrix, from=from, to=to, value=value));
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: getRateList
##
###########################################################################/**
#
# @RdocMethod getRateList
#
# @title "Get a list of events and their unscaled rates from a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# This method returns the list of event rates from the \emph{unscaled} Q matrix (as returbed bvy the \code{getEventRate} method).
# The returned list contains the rates associated with the corresponding event names.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# A list of event rates.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=3))
# # get the event rates from the unscaled Q matrix
# getRateList(p)
# # get rates from the unscaled rate matrix via virtual field
# p$rateList
# # set rates in the unscaled rate matrix
# setRateList(p, list("0->1"=1,"1->0"=1))
# p$rateList
# # set rates in the unscaled rate matrix via virtual field
# p$rateList<-list("0->1"=3,"1->0"=1);
# # check the contenst of the associated QMatrix object
# summary(p$QMatrix)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"getRateList",
class="ToleranceSubstitution",
function(
this,
...
){
if(!exists(x="PSIM_FAST")){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot get rate list as the rate matrix is undefined!\n");
}
}
return(getRateList(this$.q.matrix));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: setRateList
##
###########################################################################/**
#
# @RdocMethod setRateList
#
# @title "Setting the rates for a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# This method set the rates in the \emph{unscaled} Q matrix based on the provided list containing even names
# and the associated rates. The rate must be specified for every event!
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{value}{A list with the events names and the associated rates.}
# \item{...}{Not used.}
# }
#
# \value{
# The ToleranceSubstitution object (invisible).
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=3))
# # get the event rates from the unscaled Q matrix
# getRateList(p)
# # get rates from the unscaled rate matrix via virtual field
# p$rateList
# # set rates in the unscaled rate matrix
# setRateList(p, list("0->1"=1,"1->0"=1))
# p$rateList
# # set rates in the unscaled rate matrix via virtual field
# p$rateList<-list("0->1"=3,"1->0"=1);
# # check the contenst of the associated QMatrix object
# summary(p$QMatrix)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"setRateList",
class="ToleranceSubstitution",
function(
this,
value,
...
){
.checkWriteProtection(this);
if(!exists(x="PSIM_FAST")){
if(!is.QMatrix(this$.q.matrix)){
throw("Cannot get rate list as the rate matrix is undefined!\n");
}
else if(missing(value)){
throw("No new rate list specified!\n");
}
}
return(setRateList(this$.q.matrix, value) );
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: rescaleQMatrix
##
###########################################################################/**
#
# @RdocMethod rescaleQMatrix
#
# @title "Rescale the scaled rate matrix of a QMatrix object aggregated by a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# The QMatrix objects aggregated by the ToleranceSubstitution objects store two rate matrices: one containes
# the rates provided by the user (unscaled rate matrix), the other matrix (scaled rate matrix) is rescaled to have the
# expected number of subsitutions per unit time equal to one when the process is at equlibrium.
# This method performes the re-scaling of the scaled rate matrix in the associated QMatrix object based on
# the equlibrium distribution and the unscaled rate matrix.
#
# This method is mainly used internally as the scaled matrix is rescaled every time the unscaled matrix
# is modifed.
#
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# Invisible TRUE.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# # provide an Alphabet object and the rates
# p<-ToleranceSubstitution(alphabet=BinaryAlphabet(), rate.list=list("1->0"=1,"0->1"=3))
# # rescale rate matrix
# rescaleQMatrix(p)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"rescaleQMatrix",
class="ToleranceSubstitution",
function(
this,
...
){
if(!exists(x="PSIM_FAST")){
if(is.na(this$.q.matrix)){
return(invisible(FALSE));
}
else if(!is.QMatrix(this$.q.matrix)){
throw("Cannot rescale rate matrix because it is invalid!\n");
}
else if (any(is.na(this$.q.matrix))){
throw("Cannot rescale rate matrix because not all rates are specified!\n");
}
else if(any(is.na(this$.equ.dist))){
throw("Cannot rescale rate matrix because the equlibrium distribution is not defined properly!\n");
}
# Check for alphabet mismatch:
if(this$alphabet != this$.q.matrix$.alphabet){
throw("The process alphabet and the QMatrix alphabet is not the same! Refusing to rescale!\n");
}
}
# Set rescaling constant to zero:
K <- 0;
# get the symbols:
symbols<-this$alphabet$symbols;
orig.matrix<-this$.q.matrix$.orig.matrix;
# For every symbol:
for (i in symbols) {
# Get the equlibrium probability:
i.equ<-this$.equ.dist[[ which(colnames(this$.equ.dist) == i) ]];
for(j in symbols){
if(i == j){next}
# For every other symbol - update the constant:
K <- K + (i.equ * orig.matrix[i,j] );
}
}
Scale(this$.q.matrix,constant=(1/K));
# After rescaling the expected rate of substitutions per site
# at equlibrium is 1.
return(invisible(TRUE));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: is.ToleranceSubstitution
##
###########################################################################/**
#
# @RdocDefault is.ToleranceSubstitution
#
# @title "Check if an object is an instance of the ToleranceSubstitution class"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{this}{An object.}
# \item{...}{Not used.}
# }
#
# \value{
# TRUE or FALSE.
# }
#
# \examples{
# # create some objects
# p<-ToleranceSubstitution()
# pp<-Process()
# # chek if they inherit from ToleranceSubstitution
# is.ToleranceSubstitution(p)
# is.ToleranceSubstitution(pp)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"is.ToleranceSubstitution",
class="default",
function(
this,
...
){
if(!is.PSRoot(this)) {return(FALSE)}
if(!is.null(this$.is.general.substitution)){return(TRUE)}
if ( inherits(this, "ToleranceSubstitution")) {
this$.is.general.substitution<-TRUE;
return(TRUE);
} else {
return(FALSE)
}
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: as.character
##
###########################################################################/**
#
# @RdocMethod as.character
#
# @title "Return the character representation of a ToleranceSubstitution object"
#
# \description{
# @get "title".
# The character representation is the object id as returned by the
# \code{getId.Process} method defined in the parent class.
# }
#
# @synopsis
#
# \arguments{
# \item{x}{A ToleranceSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# A character vector of length one.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# p<-ToleranceSubstitution(name="MySubst")
# # get character representation
# as.character(p)
# # the same implicitly
# p
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"as.character",
class="ToleranceSubstitution",
function(
x,
...
){
x$.id;
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: summary
##
###########################################################################/**
#
# @RdocMethod summary
#
# @title "Summarize the properties of an object"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{object}{An object}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a PSRootSummary object.
# }
#
# \examples{
#
# # create an object
# a<-ToleranceSubstitution(alphabet=BinaryAlphabet(),rate.list=list("0->1"=1,"1->0"=2))
# # get a summary
# summary(a)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"summary",
class="ToleranceSubstitution",
function(
object,
...
){
this<-object;
.addSummaryNameId(this);
.addSummaryAlphabet(this);
if(is.null(this$.summary$"Unscaled rate matrix")){
this$.summary$"Unscaled rate matrix"<-paste( "\n\t",paste(capture.output(print(this$.q.matrix)),collapse="\n\t"),"\n",sep="");
}
this$.summary$"Equilibrium distribution"<-paste( "\n\t",paste(capture.output(print(this$.equ.dist)),collapse="\n\t"),"\n",sep="");
NextMethod();
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: clone
##
###########################################################################/**
#
# @RdocMethod clone
#
# @title "Clone a ToleranceSubstitution object"
#
# \description{
# @get "title".
#
# This method also clones the aggregated QMatrix object, but not the aggregated Alphabet
# object, as that is a good target for recycling.
# }
#
# @synopsis
#
# \arguments{
# \item{this}{A ToleranceSubstitution object.}
# \item{...}{Not used.}
# }
#
# \value{
# A ToleranceSubstitution object.
# }
#
# \examples{
# # create a ToleranceSubstitution object
# p<-ToleranceSubstitution(
# alphabet=BinaryAlphabet(),
# rate.list=list("0->1"=1,"1->0"=2),
# name="MyBinary"
# )
# # clone p
# pp<-clone(p)
# # do some checks
# p;pp
# p == p
# p == pp
# equals(p$qMatrix, pp$qMatrix)
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"clone",
class="ToleranceSubstitution",
function(
this,
...
){
# Clone the process object:
that<-clone.Object(this);
# Disable write protection:
if(that$writeProtected){
that$writeProtected<-FALSE;
}
# Clone Q matrix object:
that$.q.matrix<-clone(this$.q.matrix);
that$.q.matrix$.process<-that;
# Reassingning name to force Id update:
that$name<-that$name;
return(that);
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
##
## Method: plot
##
###########################################################################/**
#
# @RdocMethod plot
#
# @title "Create a bubble plot of the substitution process"
#
# \description{
# @get "title".
#
# Bubble plots visualize the characteristics of the
# substitution process. The area of the circles is proportional to the rates/probabilities.
# The plot is not produced if the rate matrix or the equlibrium
# distribution has undefined elements.
# }
#
# @synopsis
#
# \arguments{
# \item{x}{An object inheriting from ToleranceSubstitution.}
# \item{scale}{A scale factor affecting the area of the circles.}
# \item{...}{Not used.}
# }
#
# \value{
# The process object (invisible).
# }
#
# \examples{
# plot(BinarySubst(rate.list=list("0->1"=1,"1->0"=1.5)))
# plot(JC69())
# # get smaller circles
# plot(JC69(),scale=0.5)
# plot(F84(base.freqs=c(3/6,1/6,1/6,1/6)))
# plot(WAG())
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#
#*/###########################################################################
setMethodS3(
"plot",
class="ToleranceSubstitution",
function(
x,
scale=1,
...
){
if(!is.numeric(scale)){
throw("Scale parameter must be numeric!");
}
if(scale <= 0){
throw("Scale parameter must be positive!");
}
if(hasUndefinedRate(x)) {
throw("Cannot plot process: the rate matrix has undefined elements!");
}
if(any(is.na(x$equDist))) {
throw("Cannot plot process: the equilibrium distribution has undefined elements!");
}
qmat<-x$.q.matrix$scaledMatrix;
# setting up viewports
point_scale<-40.0;
grid.newpage();
size<-dim(qmat)[1];
dsize<-(max(c(1/size,( (0.23 * size - 0.65)/size ) )));
layout<-grid.layout(nrow=2,ncol=1,heights=c((1 - dsize), dsize),respect=TRUE);
vp1<-viewport(layout=layout,layout.pos.row=1,layout.pos.col=1);
vp2<-viewport(layout=layout,layout.pos.row=2,layout.pos.col=1);
pushViewport(vp1);
# tabulate rates
xx<-c();
yy<-c();
zz<-c();
for(cl in (colnames(qmat))){
for(rw in (rownames(qmat))){
if(rw != cl){
xx<-c(xx,cl)
yy<-c(yy,rw)
zz<-c(zz,qmat[as.character(rw), as.character(cl)]);
}
}
}
# visual aspect tuned by "magic" formulas :)
my.plot<-(qplot(x=xx,y=yy,size=zz,xlab="To:",ylab="From:",main="Rate matrix") + geom_point(colour="blue") +
scale_size_area(limits=c(0,max(zz)), name="Size:")
) + xlim(colnames(qmat)) + ylim(rev(rownames(qmat)));
print(my.plot, vp=vp1);
popViewport(1);
# equlibrium distribution
dist<-x$equDist;
xx<-c();
yy<-c();
zz<-c();
for(cl in colnames(dist)){
xx<-c(xx, cl);
yy<-c(yy, 1);
zz<-c(zz,dist[1,as.character(cl)]);
}
pushViewport(vp2);
fr<-max(zz) - min(zz);
# visual aspect tuned by "magic" formulas :)
my.plot<-(qplot(x=xx,y=yy,size=zz,xlab="Symbol",ylab="Prob:",main="Equlibrium distribution") + geom_point(colour="green") +
scale_size_area(limits=c(0,max(zz)), name="Size:",breaks=c(min(zz),min(zz) + fr*(1/3),min(zz) + fr*(2/3),max(zz))) + xlim(xx)
);
print(my.plot,vp=vp2);
popViewport(1);
return(invisible(x));
},
private=FALSE,
protected=FALSE,
overwrite=FALSE,
conflict="warning",
validators=getOption("R.methodsS3:validators:setMethodS3")
);
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.