PageRenderTime 187ms CodeModel.GetById 127ms app.highlight 50ms RepoModel.GetById 1ms app.codeStats 1ms

/GeneralInDel.R

http://github.com/sbotond/phylosim
R | 2702 lines | 852 code | 158 blank | 1692 comment | 120 complexity | a23736811e89e9bdda791d2d2ec6c5dc MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1##	
   2## Copyright 2009 Botond Sipos	
   3## See the package description for licensing information.	
   4##	
   5##########################################################################/** 
   6#
   7# @RdocClass GeneralInDel
   8# 
   9# @title "The GeneralInDel class"
  10# 
  11# \description{ 
  12#
  13#	This is a class implementing the methods which are needed by both the 
  14#	GeneralInsertor and GeneralDeletor process.
  15#	
  16#	@classhierarchy
  17# }
  18#	
  19# @synopsis
  20#	
  21# \arguments{
  22# 	\item{name}{The name of the object.}
  23#	\item{rate}{The general rate of the object.}
  24#	\item{propose.by}{A function used to propose events.}
  25#	\item{accept.by}{A function used to accept/reject events.}
  26# 	\item{...}{Additional arguments.}
  27#	}
  28# 
  29# \section{Fields and Methods}{ 
  30# 	@allmethods
  31# }
  32# 
  33# \examples{ 
  34#	# create a GeneralInDel object
  35#	# rejecting half of the events
  36#	# and proposing sizes in the range 1:10
  37#	o<-GeneralInDel(
  38#                   rate=1,
  39#                   propose.by=function(process){sample(1:10,1)},
  40#                   accept.by=function(){sample(c(TRUE,FALSE),1)}
  41#                   );
  42#	# check if inherits from GeneralInDel
  43#	is.GeneralInDel(o)
  44#	# check if it has undefined rates
  45#	hasUndefinedRate(o)
  46#	# get object summary
  47#	summary(o)
  48#	# set/get proposeBy function via virtual field
  49#	o$proposeBy<-function(process){return(3)}	# fixed event length
  50#	o$proposeBy
  51#	# set/get acceptBy function via virtual field
  52#	o$acceptBy<-function(){return(TRUE)}		# accept all events
  53#	o$acceptBy
  54#	# get/set general rate
  55#	o$rate
  56#	o$rate<-2	# double the rate
  57#	# propose event length
  58#	proposeLength(o)
  59# }
  60# 
  61# @author
  62#
  63# \seealso{ 
  64# 	Process GeneralInsertor GeneralDeletor GeneralSubstitution 
  65# }
  66# 
  67#*/###########################################################################
  68setConstructorS3(
  69  "GeneralInDel",
  70  function( 
  71		name="Anonymous", 
  72		rate=NA,
  73		propose.by=NA,
  74		accept.by=NA,
  75		... 
  76		)	{
  77
  78		any.alphabet<-AnyAlphabet();
  79		this<-Process(
  80			alphabet=any.alphabet
  81		);
  82    this<-extend(
  83      			this,
  84      			"GeneralInDel",
  85			.rate=rate,
  86			.propose.by=NA,
  87			.accept.by=NA,
  88			.is.general.indel=TRUE
  89    );
  90
  91		# Using virtual field to clear Id cache:
  92		this$name<-name;
  93		# setting propose.by
  94		if(!missing(propose.by) && is.function(propose.by)){
  95			this$proposeBy<-propose.by;
  96		}
  97		# setting accept.by
  98		if(!missing(accept.by) && is.function(accept.by)){
  99			this$acceptBy<-accept.by;
 100		}
 101
 102    		return(this);
 103  },
 104  enforceRCC=TRUE
 105);
 106
 107##	
 108## Method: checkConsistency
 109##	
 110###########################################################################/**
 111#
 112# @RdocMethod	checkConsistency
 113# 
 114# @title "Check object consistency"
 115# 
 116# \description{ 
 117#		@get "title".
 118# } 
 119# 
 120# @synopsis 
 121#
 122# \arguments{ 
 123#       \item{this}{An object.} 
 124#       \item{...}{Not used.} 
 125# } 
 126# 
 127# 
 128# \value{ 
 129#		Returns an invisible TRUE if no inconsistencies found in the object, throws 
 130#		an error otherwise. 
 131# } 
 132# 
 133# @author 
 134# 
 135# \seealso{ 
 136# 	@seeclass 
 137# } 
 138# 
 139#*/###########################################################################
 140setMethodS3(
 141	"checkConsistency", 
 142	class="GeneralInDel", 
 143	function(
 144		this,
 145		...
 146	){
 147
 148      wp<-this$writeProtected;
 149      if (wp) {
 150        this$writeProtected<-FALSE;
 151      }
 152
 153      may.fail<-function(this) {
 154
 155        if (!is.na(this$rate)) {
 156          this$rate<-this$rate;
 157        }
 158
 159				if(!is.function(this$proposeBy)){
 160					if(!is.na(this$proposeBy)){
 161						throw("proposeBy is invalid!\n");
 162					}
 163				}
 164				
 165				if(!is.function(this$acceptBy)){
 166					if(!is.na(this$acceptBy)){
 167						throw("acceptBy is invalid!\n");
 168					}
 169				}
 170
 171      }
 172      tryCatch(may.fail(this),finally=this$writeProtected<-wp);
 173			NextMethod();
 174
 175	},
 176	private=FALSE,
 177	protected=FALSE,
 178	overwrite=FALSE,
 179	conflict="warning",
 180	validators=getOption("R.methodsS3:validators:setMethodS3")
 181);
 182
 183##	
 184## Method: getRate
 185##	
 186###########################################################################/**
 187#
 188# @RdocMethod getRate
 189# 
 190# @title "Get the general rate" 
 191# 
 192# \description{ 
 193#	@get "title".
 194# } 
 195# 
 196# @synopsis 
 197# 
 198# \arguments{ 
 199# 	\item{this}{A GeneralInDel object.} 
 200# 	\item{...}{Not used.} 
 201# } 
 202# 
 203# \value{ 
 204# 	A numeric vector of length one.
 205# } 
 206# 
 207# \examples{
 208#	# create a GeneralInDel object
 209#	o<-GeneralInDel(rate=0.5)
 210#	# get/set general rate
 211#	getRate(o)
 212#	setRate(o, 1.5)
 213#	# get/set rate via virtual field
 214#	o$rate
 215#	o$rate<-0.3
 216#	o$rate
 217# } 
 218# 
 219# @author 
 220# 
 221# \seealso{ 
 222# 	@seeclass 
 223# } 
 224# 
 225#*/###########################################################################
 226setMethodS3(
 227	"getRate", 
 228	class="GeneralInDel", 
 229	function(
 230		this,
 231		...
 232	){
 233
 234		this$.rate;
 235
 236	},
 237	private=FALSE,
 238	protected=FALSE,
 239	overwrite=FALSE,
 240	conflict="warning",
 241	validators=getOption("R.methodsS3:validators:setMethodS3")
 242);
 243
 244##	
 245## Method: hasUndefinedRate
 246##	
 247###########################################################################/**
 248#
 249# @RdocMethod hasUndefinedRate
 250# 
 251# @title "Check whether the general rate of a GeneralInDel object is undefined" 
 252# 
 253# \description{ 
 254#	@get "title".
 255# } 
 256# 
 257# @synopsis 
 258# 
 259# \arguments{ 
 260# 	\item{this}{A GeneralInDel object.} 
 261# 	\item{...}{Not used.} 
 262# } 
 263# 
 264# \value{ 
 265# 	TRUE or FALSE.
 266# } 
 267# 
 268# \examples{
 269#	# create a GeneralInDel object
 270#	o<-GeneralInDel()
 271#	# check if the general rate is undefined
 272#	hasUndefinedRate(o)
 273#	# set general rate
 274#	o$rate<-1
 275#	# check rate again
 276#	hasUndefinedRate(o)
 277# } 
 278# 
 279# @author 
 280# 
 281# \seealso{ 
 282# 	@seeclass 
 283# } 
 284# 
 285#*/###########################################################################
 286setMethodS3(
 287	"hasUndefinedRate", 
 288	class="GeneralInDel", 
 289	function(
 290		this,
 291		...
 292	){
 293
 294		return(is.na(this$.rate));
 295
 296	},
 297	private=FALSE,
 298	protected=FALSE,
 299	overwrite=FALSE,
 300	conflict="warning",
 301	validators=getOption("R.methodsS3:validators:setMethodS3")
 302);
 303
 304##	
 305## Method: setRate
 306##	
 307###########################################################################/**
 308#
 309# @RdocMethod setRate
 310# 
 311# @title "Set the general rate" 
 312# 
 313# \description{ 
 314#	@get "title".
 315# } 
 316# 
 317# @synopsis 
 318# 
 319# \arguments{ 
 320# 	\item{this}{A GeneralInDel object.} 
 321#	\item{value}{The new general rate (a numeric vector of length one).}
 322# 	\item{...}{Not used.} 
 323# } 
 324# 
 325# \value{ 
 326# 	The new general rate.
 327# } 
 328# 
 329# \examples{
 330#	# create a GeneralInDel object
 331#	o<-GeneralInDel(rate=0.5)
 332#	# get/set general rate
 333#	getRate(o)
 334#	setRate(o, 1.5)
 335#	# get/set rate via virtual field
 336#	o$rate
 337#	o$rate<-0.3
 338#	o$rate
 339# } 
 340# 
 341# @author 
 342# 
 343# \seealso{ 
 344# 	@seeclass 
 345# } 
 346# 
 347#*/###########################################################################
 348setMethodS3(
 349	"setRate", 
 350	class="GeneralInDel", 
 351	function(
 352		this,
 353		value,
 354		...
 355	){
 356
 357		.checkWriteProtection(this);
 358	if(!exists(x="PSIM_FAST")){
 359		if(missing(value)) {
 360			throw("No new value provided!\n");}
 361		else if(!is.numeric(value)) {
 362			throw("Rate must be numeric!\n");
 363		} 
 364	}	
 365		this$.rate<-value;
 366		return(this$.rate);
 367
 368	},
 369	private=FALSE,
 370	protected=FALSE,
 371	overwrite=FALSE,
 372	conflict="warning",
 373	validators=getOption("R.methodsS3:validators:setMethodS3")
 374);
 375
 376##	
 377## Method: getProposeBy
 378##	
 379###########################################################################/**
 380#
 381# @RdocMethod getProposeBy
 382# \alias{getProposeBy.GeneralInsertor}
 383# 
 384# @title "Get the function used for proposing indel lengths" 
 385# 
 386# \description{ 
 387#	@get "title".
 388# } 
 389# 
 390# @synopsis 
 391# 
 392# \arguments{ 
 393# 	\item{this}{A GeneralInDel object.} 
 394# 	\item{...}{Not used.} 
 395# } 
 396# 
 397# \value{ 
 398# 	A function object.
 399# } 
 400# 
 401# \examples{
 402#	# create a GeneralInDel object
 403#	# proposing events with a constant length of 5
 404#	o<-GeneralInDel(rate=1, propose.by=function(process){return(5)});
 405#	# set/get the proposeBy function
 406#	setProposeBy(o,value=function(process){return(6)})
 407#	getProposeBy(o)
 408#	# set/get proposeBy function via virtual field
 409#	o$proposeBy<-function(process){return(3)}
 410#	o$proposeBy
 411# } 
 412# 
 413# @author 
 414# 
 415# \seealso{ 
 416# 	@seeclass 
 417# } 
 418# 
 419#*/###########################################################################
 420setMethodS3(
 421	"getProposeBy", 
 422	class="GeneralInDel", 
 423	function(
 424		this,
 425		...
 426	){
 427
 428		this$.propose.by;
 429
 430	},
 431	private=FALSE,
 432	protected=FALSE,
 433	overwrite=FALSE,
 434	conflict="warning",
 435	validators=getOption("R.methodsS3:validators:setMethodS3")
 436);
 437
 438##	
 439## Method: setProposeBy
 440##	
 441###########################################################################/**
 442#
 443# @RdocMethod setProposeBy
 444# \alias{setProposeBy.GeneralInsertor}
 445# 
 446# @title "Set the function used for proposing indel lengths" 
 447# 
 448# \description{ 
 449#	@get "title".
 450#
 451#	The function must return a numeric vector of length one. The function must have an
 452#	argument named "process" which will hold the calling process object.
 453# } 
 454# 
 455# @synopsis 
 456# 
 457# \arguments{ 
 458# 	\item{this}{A GeneralInDel object.} 
 459#	\item{value}{A function object returning a numeric vector of length one.}
 460# 	\item{...}{Not used.} 
 461# } 
 462# 
 463# \value{ 
 464# 	The function object (invisible).
 465# } 
 466# 
 467# \examples{
 468#	# create a GeneralInDel object
 469#	# proposing events with a constant length of 5
 470#	o<-GeneralInDel(rate=1, propose.by=function(process){return(5)});
 471#	# set/get the proposeBy function
 472#	setProposeBy(o,value=function(process){return(6)})
 473#	getProposeBy(o)
 474#	# set/get proposeBy function via virtual field
 475#	o$proposeBy<-function(process){return(3)}
 476#	o$proposeBy
 477# } 
 478# 
 479# @author 
 480# 
 481# \seealso{ 
 482# 	@seeclass 
 483# } 
 484# 
 485#*/###########################################################################
 486setMethodS3(
 487	"setProposeBy", 
 488	class="GeneralInDel", 
 489	function(
 490		this,
 491		value,
 492		...
 493	){
 494
 495		.checkWriteProtection(this);
 496	if(!exists(x="PSIM_FAST")){
 497		if(missing(value)) {
 498				throw("No new value provided!\n");	
 499		}
 500		else if(!is.function(value)){
 501			 throw("The value of proposeBy must be a function.!\n");	
 502		}
 503	}
 504		this$.propose.by<-value;
 505		return(invisible(this$.propose.by));
 506
 507	},
 508	private=FALSE,
 509	protected=FALSE,
 510	overwrite=FALSE,
 511	conflict="warning",
 512	validators=getOption("R.methodsS3:validators:setMethodS3")
 513);
 514
 515##	
 516## Method: getAcceptBy
 517##	
 518###########################################################################/**
 519#
 520# @RdocMethod getAcceptBy
 521# \alias{getAcceptBy.GeneralInsertor}
 522# 
 523# @title "Get the function used for accepting/rejecting indel events" 
 524# 
 525# \description{ 
 526#	@get "title".
 527# } 
 528# 
 529# @synopsis 
 530# 
 531# \arguments{ 
 532# 	\item{this}{A GeneralInDel object.} 
 533# 	\item{...}{Not used.} 
 534# } 
 535# 
 536# \value{ 
 537# 	A function object.
 538# } 
 539# 
 540# \examples{
 541#	# create a GeneralInDel object
 542#	# rejecting half of the events
 543#	o<-GeneralInDel(
 544#                   rate=1,
 545#                   propose.by=function(process){return(5)},
 546#                   accept.by=function( ){sample(c(TRUE,FALSE),1)}
 547#                   );
 548#	# set/get the acceptBy function
 549#	setAcceptBy(o,value=function(){return(FALSE)})	# reject all events
 550#	getAcceptBy(o)
 551#	# set/get acceptBy function via virtual field
 552#	o$acceptBy<-function(){return(TRUE)}		# accept all events
 553#	o$acceptBy
 554# } 
 555# 
 556# @author 
 557# 
 558# \seealso{ 
 559# 	@seeclass 
 560# } 
 561# 
 562#*/###########################################################################
 563setMethodS3(
 564	"getAcceptBy", 
 565	class="GeneralInDel", 
 566	function(
 567		this,
 568		...
 569	){
 570
 571		this$.accept.by;
 572
 573	},
 574	private=FALSE,
 575	protected=FALSE,
 576	overwrite=FALSE,
 577	conflict="warning",
 578	validators=getOption("R.methodsS3:validators:setMethodS3")
 579);
 580
 581##	
 582## Method: setAcceptBy
 583##	
 584###########################################################################/**
 585#
 586# @RdocMethod setAcceptBy
 587# \alias{setAcceptBy.GeneralInsertor}
 588# 
 589# @title "Set the function used for accepting/rejecting indel events" 
 590# 
 591# \description{ 
 592#	@get "title".
 593#
 594#	The function object must have the following arguments: process (the caller process), sequence (the target sequence), 
 595#	window (a vector containing the positions affecting acceptance).
 596# } 
 597# 
 598# @synopsis 
 599# 
 600# \arguments{ 
 601# 	\item{this}{A GeneralInDel object.} 
 602#	\item{value}{A function object.}
 603# 	\item{...}{Not used.} 
 604# } 
 605# 
 606# \value{ 
 607# 	The function object (invisible).
 608# } 
 609# 
 610# \examples{
 611#	# create a GeneralInDel object
 612#	# rejecting half of the events
 613#	o<-GeneralInDel(
 614#                   rate=1, 
 615#                   propose.by=function(process){return(5)},
 616#                   accept.by=function( ){sample(c(TRUE,FALSE),1)}
 617#                   );
 618#	# set/get the acceptBy function
 619#	setAcceptBy(o,value=function( ){return(FALSE)})	# reject all events
 620#	getAcceptBy(o)
 621#	# set/get acceptBy function via virtual field
 622#	o$acceptBy<-function(){return(TRUE)}		# accept all events
 623#	o$acceptBy
 624# } 
 625# 
 626# @author 
 627# 
 628# \seealso{ 
 629# 	@seeclass 
 630# } 
 631# 
 632#*/###########################################################################
 633setMethodS3(
 634	"setAcceptBy", 
 635	class="GeneralInDel", 
 636	function(
 637		this,
 638		value,
 639		...
 640	){
 641
 642		.checkWriteProtection(this);
 643	if(!exists(x="PSIM_FAST")){
 644		if(missing(value)) {
 645				throw("No new value provided!\n");	
 646		}
 647		else if(!is.function(value)){
 648			 throw("The value of acceptBy must be a function.!\n");	
 649		}
 650	}
 651		this$.accept.by<-value;
 652		return(invisible(this$.accept.by));
 653
 654	},
 655	private=FALSE,
 656	protected=FALSE,
 657	overwrite=FALSE,
 658	conflict="warning",
 659	validators=getOption("R.methodsS3:validators:setMethodS3")
 660);
 661
 662##	
 663## Method: proposeLength
 664##	
 665###########################################################################/**
 666#
 667# @RdocMethod proposeLength
 668# 
 669# @title "Propose indel length" 
 670# 
 671# \description{ 
 672#	@get "title".
 673#
 674#	This method simply calls the function returned by the \code{getProposeBy} method.
 675# } 
 676# 
 677# @synopsis 
 678# 
 679# \arguments{ 
 680# 	\item{this}{A GeneralInDel object.} 
 681# 	\item{...}{Not used.} 
 682# } 
 683# 
 684# \value{ 
 685# 	A numeric vector of length one (the indel length).
 686# } 
 687# 
 688# \examples{
 689#	# create a GeneralInDel object
 690#	# proposing event lengths in the range 1:10
 691#	o<-GeneralInDel(rate=1, propose.by=function(process){sample(c(1:10),1)});
 692#	# propose indel length
 693#	proposeLength(o)
 694# } 
 695# 
 696# @author 
 697# 
 698# \seealso{ 
 699# 	@seeclass 
 700# } 
 701# 
 702#*/###########################################################################
 703setMethodS3(
 704	"proposeLength", 
 705	class="GeneralInDel", 
 706	function(
 707		this,
 708		...
 709	){
 710
 711		return( this$.propose.by(this));
 712
 713	},
 714	private=FALSE,
 715	protected=FALSE,
 716	overwrite=FALSE,
 717	conflict="warning",
 718	validators=getOption("R.methodsS3:validators:setMethodS3")
 719);
 720
 721##	
 722## Method: is.GeneralIndel
 723##	
 724###########################################################################/**
 725# @RdocDefault is.GeneralInDel
 726# 
 727# @title "Check if an object inherits from the GeneralInDel class" 
 728# 
 729# \description{ 
 730#		@get "title".
 731# } 
 732# 
 733# @synopsis 
 734# 
 735# \arguments{ 
 736#		\item{this}{An object.}
 737#		\item{...}{Not used.}
 738#
 739# } 
 740# 
 741# \value{ 
 742#	TRUE or FALSE.
 743# } 
 744#
 745# \examples{
 746#	# create some objects
 747#	o<-GeneralInDel(rate=1, propose.by=function(process){sample(c(1:10),1)});
 748#	x<-GTR()
 749#	# check if they inherit from GeneralInDel
 750#	is.GeneralInDel(o)
 751#	is.GeneralInDel(x)
 752# } 
 753# 
 754# 
 755# @author 
 756# 
 757#*/###########################################################################
 758setMethodS3(
 759	"is.GeneralInDel", 
 760	class="default", 
 761	function(
 762		this,
 763		...
 764	){
 765
 766    if(!is.PSRoot(this)) {return(FALSE)}
 767    if(!is.null(this$.is.general.indel)){return(TRUE)}
 768    if ( inherits(this, "GeneralInDel")) {
 769      this$.is.general.indel<-TRUE;
 770      return(TRUE);
 771    } else {
 772      return(FALSE)
 773    }
 774
 775
 776	},
 777	private=FALSE,
 778	protected=FALSE,
 779	overwrite=FALSE,
 780	conflict="warning",
 781	validators=getOption("R.methodsS3:validators:setMethodS3")
 782);
 783
 784##	
 785## Method: summary
 786##	
 787###########################################################################/**
 788#
 789# @RdocMethod summary
 790#
 791# @title "Summarize the properties of an object"
 792#
 793# \description{
 794#       @get "title".
 795# }
 796#
 797# @synopsis
 798#
 799# \arguments{
 800#       \item{object}{An object}
 801#       \item{...}{Not used.}
 802# }
 803#
 804# \value{
 805#  Returns a PSRootSummary object.
 806# }
 807#
 808# \examples{
 809#
 810#       # create an object
 811#       a<-GeneralInDel(rate=1,propose.by=function(process){sample(c(1,2,3),1)})
 812#       # get a summary
 813#       summary(a)
 814# }
 815#
 816# @author
 817#
 818# \seealso{
 819#       @seeclass
 820# }
 821#
 822#*/###########################################################################
 823setMethodS3(
 824	"summary", 
 825	class="GeneralInDel", 
 826	function(
 827		object,
 828		...
 829	){
 830	
 831		.addSummaryNameId(object);
 832		object$.summary$"General rate"<-object$rate;
 833		NextMethod();
 834
 835	},
 836	private=FALSE,
 837	protected=FALSE,
 838	overwrite=FALSE,
 839	conflict="warning",
 840	validators=getOption("R.methodsS3:validators:setMethodS3")
 841);
 842
 843###########################################################################
 844# Class:GeneralInsertor
 845##########################################################################/** 
 846#
 847# @RdocClass GeneralInsertor
 848# 
 849# @title "The GeneralInsertor class"
 850# 
 851# \description{ 
 852#
 853#	This is a class implementing a process generating insertion events.
 854#	The rate of each event is calculated as the product of the general rate of the process 
 855#       and the "rate.multiplier" site-process specific parameter.
 856#	The simulation code calls the \code{Perform} method on the selected insertion event objects,
 857#	which call their insertion event handler to perform the insertion.
 858#
 859#	The insert lengths are proposed by the function stored in the \code{proposeBy} 
 860#	virtual field. The function must have the following arguments:
 861#	process (the insertion process object).
 862#
 863#	The insertion events are accepted or rejected by the function stored in the \code{acceptBy} virtual field.
 864#	The function must have the following arguments: process (the insertion process object), sequence (the target sequence object), 
 865#	window (a vector of positions affecting acceptance).
 866#	The probability of accepting an insertion is calculated as the product of the site-process-specific 
 867#	"insertion.tolerance" parameters of the sites neighboring the insertion. 
 868#	The number of sites considered is determined by the \code{acceptWin} virtual field.
 869#
 870#	The insert is generated by the \code{generateInsert} method by calling the function stored in the \code{generateBy} virtual field.
 871#	The default generator function truncates/duplicates the sequence object stored in the \code{templateSeq} virtual field to get a sequence
 872#	having the sampled length. After constructing the Sequence object, it  calls the \code{sampleStates.Sequence} method on the resulting object. 
 873#	That means that if we start with a template sequence which has NA states, but has a substitution process attached, then the resulting sequence
 874#       will be different every time.
 875#
 876#	Before inserting the sequence returned by \code{generateInsert}, the handler function will pass the object through the function stored in the
 877#	\code{insertHook} virtual field. This allows to perform arbitrary modifications on the inserted Sequence object.
 878#
 879#	The sequence is inserted randomly on the left or the right of the target position.
 880#
 881#	@classhierarchy
 882# }
 883#	
 884# @synopsis
 885#	
 886# \arguments{
 887# 	\item{name}{The name of the object.}
 888#	\item{rate}{The general rate of the object (no default).}
 889#       \item{propose.by}{A function used to propose events (no default).}
 890#       \item{accept.by}{A function used to accept/reject events (no default).}
 891#	\item{template.seq}{A Sequence object used as a template for generating insertions (no default).}
 892#	\item{insert.hook}{A function object, see \code{setInsertHook} (no default).}
 893#	\item{accept.win}{A window of sites affecting the acceptance of insert events.}
 894# 	\item{...}{Additional arguments.}
 895#	}
 896# 
 897# \section{Fields and Methods}{ 
 898# 	@allmethods
 899# }
 900# 
 901# \examples{ 
 902#	# create a GeneralInsertor object
 903#	i<-GeneralInsertor(
 904#		name="GIN",
 905#		rate=1,
 906#		propose.by=function(process){4}, # fixed insert length
 907#		acceptBy=function(process,sequence,window){TRUE},# always accept insertions
 908#		template.seq=NucleotideSequence(string="A"),# a boring template sequence
 909#		insert.hook=function(seq){ return(seq)},# a boring insert hook
 910#		accept.win=2 #4 sites affecting acceptance
 911#	)
 912#	i
 913#	# check if object inherits from GeneralInsertor
 914#	is.GeneralInsertor(i)
 915#	# get object summary
 916#	summary(i)
 917#	# set/get general rate
 918#	i$rate<-0.5
 919#	i$rate
 920#	# set/get name
 921#	i$name<-"Ins"
 922#	i$name
 923#	# set/get proposeBy
 924#	# sample insertion length between 1 and 10
 925#	i$proposeBy<-function(process){sample(1:10,1)}
 926#	i$proposeBy
 927#	# set/get acceptBy
 928#	# reject half of the insertions
 929#	i$acceptBy<-function(process, sequence, window){ sample(c(TRUE,FALSE), 1) }
 930#	i$acceptBy
 931#	# get generateBy
 932#	i$generateBy
 933#	# set/get acceptWin
 934#	i$acceptWin<-1;
 935#	# set/get insert hook
 936#	i$insertHook<-function(
 937#                           seq, 
 938#                           target.seq,
 939#                           event.pos,
 940#                           insert.pos
 941#                           ){ attachProcess(seq, GTR() );seq} 
 942#	i$insertHook
 943#	# set/get template sequence
 944#	i$templateSeq<-NucleotideSequence(
 945#                                       length=5,
 946#                                       processes=list(list(JC69()))
 947#                                   ) # length: 5, states: NA
 948#	i$templateSeq
 949#	# generate an insert sequence
 950#	generateInsert(i)
 951#	# create a sequence object and attach the process i
 952#	s<-NucleotideSequence(string="AAAAA",processes=list(list(i)))
 953#       # set rate multiplier
 954#       setRateMultipliers(s,i,2)
 955#       # get the list of active events from site 2
 956#       events<-getEventsAtSite(i,s$sites[[2]])
 957#       events
 958#       # set postition for event
 959#       e<-events[[1]]
 960#       e$.position<-2  
 961#       # print sequence
 962#       s
 963#       # perform event
 964#       Perform(e)
 965#       # check sequence again
 966#       s
 967# }
 968# 
 969# @author
 970#
 971# \seealso{ 
 972# 	GeneralInDel DiscreteInsertor ContinuousInsertor BrownianInsertor
 973# }
 974# 
 975#*/###########################################################################
 976setConstructorS3(
 977  "GeneralInsertor",
 978  function( 
 979		name="Anonymous", 
 980		rate=NA,
 981		propose.by=NA,
 982		accept.by=NA,
 983		template.seq=NA,
 984		insert.hook=NA,
 985		accept.win=NA,
 986		... 
 987		)	{
 988
 989		this<-GeneralInDel(
 990			rate=rate,
 991			propose.by=propose.by,
 992			accept.by=accept.by
 993		);
 994
 995    this<-extend(
 996      this,
 997      "GeneralInsertor",
 998			.generate.by=NA,
 999			.handler.template=NA,
1000			.template.seq=NA,
1001			.insert.hook=NA,
1002			.accept.win=1,
1003			.is.general.insertor=TRUE
1004    );
1005		# Using virtual field to clear Id cache:
1006		this$name<-name;
1007
1008		# Adding insertion tolerance parameter.
1009    .addSiteSpecificParameter(
1010      this,
1011      id="insertion.tolerance",
1012      name="Insertion tolerance parameter",
1013      value=as.double(1), # Accept all by default
1014      type="numeric"
1015    );
1016	
1017		if(!missing(template.seq)){
1018			this$templateSeq<-template.seq;
1019		}
1020
1021		this$acceptBy<-function(process=NA,sequence=NA,range=NA){
1022			
1023				accept.prob<-c();
1024				for(site in sequence$.sites[range]){
1025						# Discard the site if the process is not attached to it:
1026						if(!isAttached(site, process)){
1027							next();
1028						}
1029						else {
1030							accept.prob<-c(accept.prob, getParameterAtSite(process, site, "insertion.tolerance")$value);
1031						}
1032				}
1033				accept.prob<-prod(as.numeric(accept.prob));
1034
1035
1036			  # Accept/reject:
1037				return( sample(c(TRUE,FALSE),replace=FALSE,prob=c(accept.prob,(1-accept.prob)),size=1) );
1038		}
1039
1040	###	
1041
1042	 this$generateBy<-function(process=NA,length=NA,target.seq=NA,event.pos=NA,insert.pos=NA){
1043
1044		if(!exists(x="PSIM_FAST")){	
1045			if(is.na(length) | (length(length) == 0) | length == 0){
1046				throw("Invalid insert length!\n");
1047			}	
1048			else if(is.na(process$.template.seq)){
1049				throw("Cannot generate insert without template sequence!\n");
1050			}
1051		}
1052
1053			times<-( ceiling( length/this$.template.seq$.length) );
1054			to.delete<-( ( (this$.template.seq$.length) * times) - length);
1055
1056			tmp<-clone(this$.template.seq);
1057		
1058			if( (times-1) > 0){
1059				for(i in 1:(times-1)){
1060					insertSequence(tmp,process$.template.seq,tmp$length);
1061				}
1062			}
1063
1064			if(to.delete > 0){
1065				deleteSubSequence(tmp,(tmp$length - to.delete + 1):tmp$length);
1066			}
1067			return(tmp);
1068				
1069	 }
1070
1071	if(!missing(insert.hook)){
1072		this$insertHook<-insert.hook;
1073	}
1074
1075	###	
1076	 this$.handler.template<-function(event=NA) {
1077
1078				if(!is.na(event)){
1079
1080					 WINDOW.SIZE<-this$.accept.win;
1081					 # Using temporary varibales for clarity:
1082					 position<-event$.position;
1083					 process<-event$.process;
1084					 sequence<-event$.site$.sequence;
1085					 details<-list();
1086					 details$type<-"insertion";
1087
1088					 # Propose the direction:
1089					 direction<-sample(c("LEFT","RIGHT"),replace=FALSE,size=1);
1090
1091					 # Set insertion tolerance window:
1092					 window<-integer();
1093					 insert.pos<-position;
1094					 if(direction == "LEFT") {
1095							window<-(position-WINDOW.SIZE):position;
1096					 		insert.pos<-(position-1);
1097					 }
1098					 else if (direction == "RIGHT"){
1099							window<-position:(position+WINDOW.SIZE);
1100					 }
1101					 else {
1102						throw("You should never see this message!\n");
1103					}
1104
1105					details$position<-insert.pos;
1106					details$accepted<-FALSE;
1107
1108					# Discard illegal positions:
1109					window<-window[ window > 0 & window <= sequence$.length];
1110				  if(process$.accept.by(process=process,sequence,window)){
1111							details$accepted<-TRUE;
1112							insert<-generateInsert(process,target.seq=sequence,event.pos=position,insert.pos=insert.pos);
1113							details$length<-insert$length;
1114							# Call the insert hook:
1115							if(is.function(this$.insert.hook)){
1116								insert<-this$.insert.hook(seq=insert,target.seq=sequence,event.pos=position,insert.pos=insert.pos);
1117							}
1118							insertSequence(sequence,insert, insert.pos,process=process);
1119					}
1120					return(details);
1121					
1122				}
1123		 }
1124		###
1125
1126    return(this);
1127  },
1128  enforceRCC=TRUE
1129);
1130
1131##	
1132## Method: is.GeneralInsertor
1133##	
1134###########################################################################/**
1135#
1136# @RdocDefault is.GeneralInsertor
1137# 
1138# @title "Check whether an object inherits from GeneralInsertor" 
1139# 
1140# \description{ 
1141#		@get "title".
1142# } 
1143# 
1144# @synopsis 
1145# 
1146# \arguments{ 
1147#		\item{this}{An object.}
1148#		\item{...}{Not used.}
1149#
1150# } 
1151# 
1152# \value{ 
1153#	TRUE or FALSE.
1154# } 
1155#
1156# \examples{
1157#	# create some objects
1158#	d<-GeneralDeletor()
1159#	i<-GeneralInsertor()
1160#	# check if they inherit from GeneralInsertor
1161#	is.GeneralInsertor(i)
1162#	is.GeneralInsertor(d)
1163# }
1164# 
1165# @author 
1166# 
1167#*/###########################################################################
1168setMethodS3(
1169	"is.GeneralInsertor", 
1170	class="default", 
1171	function(
1172		this,
1173		...
1174	){
1175
1176    if(!is.PSRoot(this)) {return(FALSE)}
1177    if(!is.null(this$.is.general.insertor)){return(TRUE)}
1178    if ( inherits(this, "GeneralInsertor")) {
1179      this$.is.general.insertor<-TRUE;
1180      return(TRUE);
1181    } else {
1182      return(FALSE)
1183    }
1184
1185
1186	},
1187	private=FALSE,
1188	protected=FALSE,
1189	overwrite=FALSE,
1190	conflict="warning",
1191	validators=getOption("R.methodsS3:validators:setMethodS3")
1192);
1193
1194##	
1195## Method: checkConsistency
1196##	
1197###########################################################################/**
1198#
1199# @RdocMethod	checkConsistency
1200# 
1201# @title "Check object consistency"
1202# 
1203# \description{ 
1204#		@get "title".
1205# } 
1206# 
1207# @synopsis 
1208#
1209# \arguments{ 
1210#       \item{this}{An object.} 
1211#       \item{...}{Not used.} 
1212# } 
1213# 
1214# 
1215# \value{ 
1216#		Returns an invisible TRUE if no inconsistencies found in the object, throws 
1217#		an error otherwise. 
1218# } 
1219# 
1220# @author 
1221# 
1222# \seealso{ 
1223# 	@seeclass 
1224# } 
1225# 
1226#*/###########################################################################
1227setMethodS3(
1228	"checkConsistency", 
1229	class="GeneralInsertor", 
1230	function(
1231		this,
1232		...
1233	){
1234
1235		      wp<-this$writeProtected;
1236      if (wp) {
1237        this$writeProtected<-FALSE;
1238      }
1239
1240      may.fail<-function(this) {
1241
1242        if (!is.na(this$templateSeq)) {
1243          this$templateSeq<-this$templateSeq;
1244        }
1245
1246        if(!is.function(this$generateBy)){
1247          if(!is.na(this$generateBy)){
1248            throw("generateBy is invalid!\n");
1249          }
1250        }
1251
1252      }
1253      tryCatch(may.fail(this),finally=this$writeProtected<-wp);
1254      NextMethod();
1255
1256	},
1257	private=FALSE,
1258	protected=FALSE,
1259	overwrite=FALSE,
1260	conflict="warning",
1261	validators=getOption("R.methodsS3:validators:setMethodS3")
1262);
1263
1264##	
1265## Method: getEventsAtSite
1266##	
1267###########################################################################/**
1268#
1269# @RdocMethod	getEventsAtSite
1270# 
1271# @title "Generate insertion event object given the state of the target site" 
1272# 
1273# \description{ 
1274#	@get "title".
1275#	
1276#	This method generates a list with one insertion event. The rate of the 
1277#	event is calculated as the product of the general rate of the process 
1278#	and the "rate.multiplier" site-process specific parameter. An empty list is
1279#	returned if the rate is zero or NA.
1280# } 
1281# 
1282# @synopsis 
1283# 
1284# \arguments{ 
1285# 	\item{this}{A GeneralInsertor object.} 
1286# 	\item{target.site}{A Site object.} 
1287# 	\item{...}{Not used.} 
1288# } 
1289# 
1290# \value{ 
1291# 	A list of Event objects.
1292# } 
1293# 
1294# \examples{
1295#	# create a sequence object
1296#	s<-NucleotideSequence(string="AAAA")
1297#	# create a GeneralInsertor process, provide template sequence.
1298#	# propsed insert lengths:3, always accept.
1299#	i<-GeneralInsertor(
1300#		rate=0.5,
1301#		template.seq=NucleotideSequence(string="GGG"),
1302#		propose.by=function(process){3},
1303#		accept.by=function(process,sequence,window){TRUE}
1304#	)
1305#	# attach process to site
1306#	s$processes<-list(list(i));
1307#	# set rate multiplier
1308#	setRateMultipliers(s,i,2)
1309#	# get the list of active events from site 2
1310#	events<-getEventsAtSite(i,s$sites[[2]])
1311#	events
1312#	# set postition for event
1313#	e<-events[[1]]
1314#	e$.position<-2	
1315#	# print sequence
1316#	s
1317#	# perform event
1318#	Perform(e)
1319#	# check sequence again
1320#	s
1321# } 
1322# 
1323# @author 
1324# 
1325# \seealso{ 
1326# 	GeneralInsertor GeneralInDel Process Event
1327# } 
1328# 
1329#*/###########################################################################
1330setMethodS3(
1331	"getEventsAtSite", 
1332	class="GeneralInsertor", 
1333	function(
1334		this,
1335		target.site,
1336		...
1337	){
1338
1339	if(!exists(x="PSIM_FAST")){
1340		if(missing(target.site)) {
1341			throw("No target site provided!\n");
1342		}
1343		if(!is.Site(target.site)) {
1344			throw("Target site invalid!\n");
1345		}
1346		else if(!is.function(this$.propose.by)) {
1347			throw("proposeBy is not set, cannot propose insertion!\n");
1348		} 
1349		else if (!is.function(this$.accept.by)){
1350			throw("acceptBy is not set, cannot generate insertion event!\n");
1351		}
1352	}
1353
1354		# Just return an empty list if the rate is undefined or zero:
1355		if( is.na(this$.rate) | this$.rate == 0) {
1356			return(list());
1357		}
1358
1359		 # Clone the event template object:
1360		 insertion.event<-clone(this$.event.template);
1361		 # Set the target position passed in a temporary field:
1362		 insertion.event$.position<-target.site$.position;
1363		 # Set the target site:
1364		 insertion.event$.site<-target.site;
1365		 # Set event name:
1366		 insertion.event$.name<-"Insertion";
1367		 # Set the generator process:
1368		 insertion.event$.process<-this;
1369		
1370		 # Event rate is the product of the general rate and the 
1371		 # site specific rate multiplier:
1372		 rate.multiplier<-target.site$.processes[[this$.id]]$site.params[["rate.multiplier"]]$value;
1373		 if(rate.multiplier == 0 ) {
1374			return(list());
1375		 }
1376		 insertion.event$.rate<-(this$.rate * rate.multiplier );
1377
1378		 # Set the handler for the insertion event:
1379		 insertion.event$.handler<-this$.handler.template;
1380
1381		# Return the event object in a list:
1382		list(insertion.event);
1383
1384	},
1385	private=FALSE,
1386	protected=FALSE,
1387	overwrite=FALSE,
1388	conflict="warning",
1389	validators=getOption("R.methodsS3:validators:setMethodS3")
1390);
1391
1392
1393##	
1394## Method: generateInsert
1395##	
1396###########################################################################/**
1397#
1398# @RdocMethod generateInsert
1399# 
1400# @title "Generate an insert" 
1401# 
1402# \description{ 
1403#	@get "title".
1404#
1405#	This method uses the function stgored in the \code{proposeBy} virtual field to
1406#	sample the insert length and then calls the function stored in the \code{generateBy}
1407#	field to generate the insert. 	
1408#
1409#	The default \code{generateBy} function set by the GeneralInsertor constructor truncates/repeats
1410#	the template sequence stored in the \code{templateSeq} field to have the sequence with the right size
1411#	and then calls the \code{sampleStates} method on the resulting object. That means that if we start with a
1412#	template sequence which has NA states, but has a substitution process attached, then the resulting sequence
1413#	will be different every time the \code{generateInsert} method is called.
1414#
1415#	The \code{generateBy}, \code{proposeBy} and \code{templateSeq} fields must be set in order to use this method.
1416# } 
1417# 
1418# @synopsis 
1419# 
1420# \arguments{ 
1421# 	\item{this}{A GeneralInsertor object.} 
1422#	\item{length}{Generate an insert with the specified length if this argument is present.}
1423#	\item{target.seq}{The Sequence object targeted by the insertion (optional). This argument is passed to the \code{generateBy} method.}
1424#	\item{event.pos}{The position of the site proposing the insertion (optional). This argument is passed to the \code{generateBy} method.}
1425#	\item{insert.pos}{The position of the insertion in the target sequence (optional). This argument is passed to the \code{generateBy} method.}
1426# 	\item{...}{Not used.} 
1427# } 
1428# 
1429# \value{ 
1430# 	A Sequence object.
1431# } 
1432# 
1433# \examples{
1434#	# build the template sequence
1435#	ts<-NucleotideSequence(length = 10,processes=list(list(JC69())));
1436#	# fix some site states
1437#	setStates(ts,"A",c(1,2));
1438#	setStates(ts,"T",c(5,6));
1439#	setStates(ts,"C",c(9,10));
1440#	# print template sequence
1441#	ts
1442#	# create a GeneralInsertor object
1443#	i<-GeneralInsertor(
1444#		rate=0.5,
1445#		template.seq=ts,
1446#		propose.by=function(process){sample(c(5:50),1)}, # inserts between 5 and 50
1447#	)
1448#	# generate some inserts
1449#	generateInsert(i)
1450#	generateInsert(i)
1451#	generateInsert(i)
1452#	generateInsert(i)
1453# } 
1454# 
1455# @author 
1456# 
1457# \seealso{ 
1458# 	@seeclass 
1459# } 
1460# 
1461#*/###########################################################################
1462setMethodS3(
1463	"generateInsert", 
1464	class="GeneralInsertor", 
1465	function(
1466		this,
1467		length=NA,
1468		target.seq=NA,
1469		event.pos=NA,
1470		insert.pos=NA,
1471		...
1472	){
1473
1474		if(missing(length)){
1475			length<-this$.propose.by(process=this);
1476		}
1477		insert<-this$.generate.by(process=this,length=length,target.seq=target.seq,event.pos=event.pos,insert.pos=insert.pos);
1478		sampleStates(insert);	
1479		return(insert);	
1480
1481	},
1482	private=FALSE,
1483	protected=FALSE,
1484	overwrite=FALSE,
1485	conflict="warning",
1486	validators=getOption("R.methodsS3:validators:setMethodS3")
1487);
1488
1489##	
1490## Method: getGenerateBy
1491##	
1492###########################################################################/**
1493#
1494# @RdocMethod getGenerateBy
1495# 
1496# @title "Get the function object used for generating inserts" 
1497# 
1498# \description{ 
1499#	@get "title".
1500# } 
1501# 
1502# @synopsis 
1503# 
1504# \arguments{ 
1505# 	\item{this}{A GeneralInsertor object.} 
1506# 	\item{...}{Not used.} 
1507# } 
1508# 
1509# \value{ 
1510# 	A function object.
1511# } 
1512# 
1513# \examples{
1514#	# create a GeneralInsertor object
1515#	i<-GeneralInsertor(
1516#		rate=0.5,
1517#		propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
1518#		template.seq=NucleotideSequence(string="AAAAAAA")
1519#	)
1520#
1521#	# save insert generator
1522#	old.gen<-getGenerateBy(i)
1523#	# set a new insert generator
1524#	i$generateBy<-function(
1525#                           process,
1526#                           length, 
1527#                           target.seq,
1528#                           event.pos,
1529#                           insert.pos
1530#                        ){ 
1531#                           return(NucleotideSequence(string="AATTGGCC"))
1532#                           }
1533#	# get the generator function
1534#	i$generateBy
1535#	# generate insert
1536#	generateInsert(i)
1537#	# restore old generator
1538#	i$generateBy<-old.gen
1539#	# generate insert
1540#	generateInsert(i)
1541# } 
1542# 
1543# @author 
1544# 
1545# \seealso{ 
1546# 	@seeclass 
1547# } 
1548# 
1549#*/###########################################################################
1550setMethodS3(
1551	"getGenerateBy", 
1552	class="GeneralInsertor", 
1553	function(
1554		this,
1555		...
1556	){
1557
1558		this$.generate.by;
1559
1560	},
1561	private=FALSE,
1562	protected=FALSE,
1563	overwrite=FALSE,
1564	conflict="warning",
1565	validators=getOption("R.methodsS3:validators:setMethodS3")
1566);
1567
1568##	
1569## Method: setGenerateBy
1570##
1571###########################################################################/**
1572#
1573# @RdocMethod setGenerateBy
1574# 
1575# @title "Set the function object used for generating inserts" 
1576# 
1577# \description{ 
1578#	@get "title".
1579#	The provided function must return a Sequence object whne called and must have the
1580#	following arguments: process, length, target.seq, event.pos, insert.pos (see \code{generateInsert.GeneralInsertor}).
1581# } 
1582# 
1583# @synopsis 
1584# 
1585# \arguments{ 
1586# 	\item{this}{A GeneralInsertor object.} 
1587#	\item{value}{A function object.}
1588# 	\item{...}{Not used.} 
1589# } 
1590# 
1591# \value{ 
1592# 	The function object.
1593# } 
1594# 
1595# \examples{
1596#	# create a GeneralInsertor object
1597#	i<-GeneralInsertor(
1598#		rate=0.5,
1599#		propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
1600#		template.seq=NucleotideSequence(string="AAAAAAA")
1601#	)
1602#
1603#	# save insert generator
1604#	old.gen<-getGenerateBy(i)
1605#	# set a new insert generator
1606#	i$generateBy<-function(
1607#                           process,
1608#                           length,
1609#                           target.seq,
1610#                           event.pos,
1611#                           insert.pos){ 
1612#                   return(NucleotideSequence(string="AATTGGCC"))
1613#                   }
1614#	# get the generator function
1615#	i$generateBy
1616#	# generate insert
1617#	generateInsert(i)
1618#	# restore old generator
1619#	i$generateBy<-old.gen
1620#	# generate insert
1621#	generateInsert(i)
1622# } 
1623# 
1624# @author 
1625# 
1626# \seealso{ 
1627# 	@seeclass 
1628# } 
1629# 
1630#*/###########################################################################
1631setMethodS3(
1632	"setGenerateBy", 
1633	class="GeneralInsertor", 
1634	function(
1635		this,
1636		value,
1637		...
1638	){
1639
1640		.checkWriteProtection(this);
1641	if(!exists(x="PSIM_FAST")){
1642		if(missing(value)) {
1643				throw("No new value provided!\n");	
1644		}
1645		else if(!is.function(value)){
1646			 throw("The value of generateBy must be a function.!\n");	
1647		}
1648	}
1649		this$.generate.by<-value;
1650		return(this$.generate.by);
1651
1652	},
1653	private=FALSE,
1654	protected=FALSE,
1655	overwrite=FALSE,
1656	conflict="warning",
1657	validators=getOption("R.methodsS3:validators:setMethodS3")
1658);
1659
1660##	
1661## Method: getTemplateSeq
1662##	
1663###########################################################################/**
1664#
1665# @RdocMethod getTemplateSeq
1666# 
1667# @title "Get the template sequence object" 
1668# 
1669# \description{ 
1670#	@get "title".
1671#	The template sequence object is used by the default \code{generateBy} function
1672#	to generate insert sequences.
1673# } 
1674# 
1675# @synopsis 
1676# 
1677# \arguments{ 
1678# 	\item{this}{A GeneralInsertor object.} 
1679# 	\item{...}{Not used.} 
1680# } 
1681# 
1682# \value{ 
1683# 	A Sequence object or NA.
1684# } 
1685# 
1686# \examples{
1687#	# create a GeneralInsertor object
1688#	i<-GeneralInsertor(
1689#		rate=0.5,
1690#		propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
1691#		template.seq=NucleotideSequence(string="AAAAAAA")
1692#	)
1693#	# get template sequence
1694#	getTemplateSeq(i)
1695#	# get template sequence via virtual field
1696#	i$templateSeq
1697#	# set template sequence
1698#	setTemplateSeq(i, NucleotideSequence(string="C"));
1699#	# generate insert
1700#	generateInsert(i)
1701#	# set template sequence via virtual field
1702#	i$templateSeq<-NucleotideSequence(string="G")
1703#	# generate insert
1704#	generateInsert(i)
1705# } 
1706# 
1707# @author 
1708# 
1709# \seealso{ 
1710# 	@seeclass 
1711# } 
1712# 
1713#*/###########################################################################
1714setMethodS3(
1715	"getTemplateSeq", 
1716	class="GeneralInsertor", 
1717	function(
1718		this,
1719		...
1720	){
1721
1722		this$.template.seq;
1723
1724	},
1725	private=FALSE,
1726	protected=FALSE,
1727	overwrite=FALSE,
1728	conflict="warning",
1729	validators=getOption("R.methodsS3:validators:setMethodS3")
1730);
1731
1732##	
1733## Method: setTemplateSeq
1734##	
1735###########################################################################/**
1736#
1737# @RdocMethod setTemplateSeq
1738# 
1739# @title "Set the template sequence object" 
1740# 
1741# \description{ 
1742#	@get "title".
1743#	The template sequence object is used by the default \code{generateBy} function
1744#	to generate insert sequences.
1745# } 
1746# 
1747# @synopsis 
1748# 
1749# \arguments{ 
1750# 	\item{this}{A GeneralInsertor object.} 
1751#	\item{value}{A Sequence object.}
1752# 	\item{...}{Not used.} 
1753# } 
1754# 
1755# \value{ 
1756# 	The Sequence object.
1757# } 
1758# 
1759# \examples{
1760#	# create a GeneralInsertor object
1761#	i<-GeneralInsertor(
1762#		rate=0.5,
1763#		propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
1764#		template.seq=NucleotideSequence(string="AAAAAAA")
1765#	)
1766#	# get template sequence
1767#	getTemplateSeq(i)
1768#	# get template sequence via virtual field
1769#	i$templateSeq
1770#	# set template sequence
1771#	setTemplateSeq(i, NucleotideSequence(string="C"));
1772#	# generate insert
1773#	generateInsert(i)
1774#	# set template sequence via virtual field
1775#	i$templateSeq<-NucleotideSequence(string="G")
1776#	# generate insert
1777#	generateInsert(i)
1778# } 
1779# 
1780# @author 
1781# 
1782# \seealso{ 
1783# 	@seeclass 
1784# } 
1785# 
1786#*/###########################################################################
1787setMethodS3(
1788	"setTemplateSeq", 
1789	class="GeneralInsertor", 
1790	function(
1791		this,
1792		value,
1793		...
1794	){
1795
1796		.checkWriteProtection(this);
1797	if(!exists(x="PSIM_FAST")){
1798		if(missing(value)) {
1799				throw("No new template sequence provided!\n");	
1800		}
1801		else if(!is.Sequence(value)){
1802			 throw("Sequence object is invalid!\n");	
1803		}
1804		else if(value$length == 0) {
1805			throw("Cannot set template sequence of length zero!\n");
1806		}
1807	}
1808		this$.template.seq<-clone(value);
1809		for (site in this$.template.seq$.sites){
1810			site$.ancestral<-this;
1811		}
1812
1813	},
1814	private=FALSE,
1815	protected=FALSE,
1816	overwrite=FALSE,
1817	conflict="warning",
1818	validators=getOption("R.methodsS3:validators:setMethodS3")
1819);
1820
1821##	
1822## Method: getAcceptWin
1823##	
1824###########################################################################/**
1825#
1826# @RdocMethod getAcceptWin
1827# 
1828# @title "Get the size of the acceptance window" 
1829# 
1830# \description{ 
1831#	@get "title"
1832#
1833#	This parameter determines the number of sites neighbouring the position (from left and right) of the insertion considered when accepting/rejecting 
1834#	a proposed insertion. The "insertion.tolerance" parameter is retrived from sites falling in the window specified by this parameter.
1835#	The default value is 1, so the two neighbouring sites are considered by default.
1836#	
1837# } 
1838# 
1839# @synopsis 
1840# 
1841# \arguments{ 
1842# 	\item{this}{A GeneralInsertor object.} 
1843# 	\item{...}{Not used.} 
1844# } 
1845# 
1846# \value{ 
1847# 	A numeric vector of length one.
1848# } 
1849# 
1850# \examples{
1851#	# create a GeneralInsertor object
1852#	i<-GeneralInsertor(rate=0.5);
1853#	# get acceptance window size
1854#	getAcceptWin(i)
1855#	# get acceptance window size via virtual field
1856#	i$acceptWin
1857#	# set acceptance window size
1858#	setAcceptWin(i,2)
1859#	# set acceptance window size via virtual field
1860#	i$acceptWin<-3
1861#	i$acceptWin
1862# } 
1863# 
1864# @author 
1865# 
1866# \seealso{ 
1867# 	@seeclass 
1868# } 
1869# 
1870#*/###########################################################################
1871setMethodS3(
1872	"getAcceptWin", 
1873	class="GeneralInsertor", 
1874	function(
1875		this,
1876		...
1877	){
1878
1879		this$.accept.win;
1880
1881	},
1882	private=FALSE,
1883	protected=FALSE,
1884	overwrite=FALSE,
1885	conflict="warning",
1886	validators=getOption("R.methodsS3:validators:setMethodS3")
1887);
1888
1889##	
1890## Method: setAcceptWin
1891##	
1892###########################################################################/**
1893#
1894# @RdocMethod setAcceptWin
1895# 
1896# @title "Set the size of the acceptance window" 
1897# 
1898# \description{ 
1899#	@get "title"
1900#
1901#	This parameter determines the number of sites neighbouring the position (from left and right) of the insertion considered when accepting/rejecting 
1902#	a proposed insertion. The "insertion.tolerance" parameter is retrived from sites falling in the window specified by this parameter.
1903#	The default value is 1, so the two neighbouring sites are considered by default.
1904#	
1905# } 
1906# 
1907# @synopsis 
1908# 
1909# \arguments{ 
1910# 	\item{this}{A GeneralInsertor object.} 
1911#	\item{value}{An integer vector of length one.}
1912# 	\item{...}{Not used.} 
1913# } 
1914# 
1915# \value{ 
1916# 	The new value.
1917# } 
1918# 
1919# \examples{
1920#	# create a GeneralInsertor object
1921#	i<-GeneralInsertor(rate=0.5);
1922#	# get acceptance window size
1923#	getAcceptWin(i)
1924#	# get acceptance window size via virtual field
1925#	i$acceptWin
1926#	# set acceptance window size
1927#	setAcceptWin(i,2)
1928#	# set acceptance window size via virtual field
1929#	i$acceptWin<-3
1930#	i$acceptWin
1931# } 
1932# 
1933# @author 
1934# 
1935# \seealso{ 
1936# 	@seeclass 
1937# } 
1938# 
1939#*/###########################################################################
1940setMethodS3(
1941	"setAcceptWin", 
1942	class="GeneralInsertor", 
1943	function(
1944		this,
1945		value,
1946		...
1947	){
1948
1949	.checkWriteProtection(this);
1950	if(!exists(x="PSIM_FAST")){
1951		if(missing(value)){
1952			throw("No new value provided");
1953		}
1954		else if(!all(is.numeric(value)) | (length(value) != 1)){
1955			throw("The new value must be a numeric vector of length one.");
1956		}
1957	}
1958		this$.accept.win<-floor(value);
1959		return(this$.accept.win);
1960	},
1961	private=FALSE,
1962	protected=FALSE,
1963	overwrite=FALSE,
1964	conflict="warning",
1965	validators=getOption("R.methodsS3:validators:setMethodS3")
1966);
1967
1968##	
1969## Method: getInsertHook
1970##	
1971###########################################################################/**
1972#
1973# @RdocMethod getInsertHook
1974# 
1975# @title "Get the insert hook function" 
1976# 
1977# \description{ 
1978#	@get "title".
1979#
1980#	The insert hook allows to make various modifications on the insert before performing the insertion.
1981#
1982#	The insert hook function is called by the insertion event handler function. The insert hook takes the 
1983#	sequence generated by the \code{generateInsert} method throught the "seq" argument. The function
1984#	must return a Sequnece object, which will be inserted in the target sequence.
1985# } 
1986# 
1987# @synopsis 
1988# 
1989# \arguments{ 
1990# 	\item{this}{A GeneralInsertor object.} 
1991# 	\item{...}{Not used.} 
1992# } 
1993# 
1994# \value{ 
1995# 	A function object.
1996# } 
1997# 
1998# \examples{
1999#	# create a GeneralInsertor object
2000#	i<-GeneralInsertor(
2001#		rate=0.5,
2002#		propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
2003#		template.seq=NucleotideSequence(length=5,processes=list(list(JC69())))
2004#	)
2005#	# set a dummy insert hook
2006#	setInsertHook(i,function(seq){return(seq)})
2007#	# set a new insert hook via virtual field
2008#	i$insertHook<-function(seq){
2009#		seq$processes<-list(list(GTR())) # replace the subsitution process
2010#		return(seq)
2011#	}
2012#	# get the insert hook via virtual field
2013#	i$insertHook
2014#	# get the insert hook
2015#	getInsertHook(i)
2016# } 
2017# 
2018# @author 
2019# 
2020# \seealso{ 
2021# 	@seeclass 
2022# } 
2023# 
2024#*/###########################################################################
2025setMethodS3(
2026	"getInsertHook", 
2027	class="GeneralInsertor", 
2028	function(
2029		this,
2030		...
2031	){
2032
2033		this$.insert.hook;
2034
2035	},
2036	private=FALSE,
2037	protected=FALSE,
2038	overwrite=FALSE,
2039	conflict="warning",
2040	validators=getOption("R.methodsS3:validators:setMethodS3")
2041);
2042
2043##	
2044## Method: setInsertHook
2045##	
2046###########################################################################/**
2047#
2048# @RdocMethod setInsertHook
2049# 
2050# @title "Set the insert hook function" 
2051# 
2052# \description{ 
2053#	@get "title".
2054#
2055#	The insert hook allows to make various modifications on the insert before performing the insertion.
2056#	The function must have the following arguments: seq (the sequence object to insert), target.seq (the target Sequence object), 
2057#	event.pos (the position of the site which generated the insertion event), insert.pos (the position of the insertion).
2058#
2059#	The insert hook function is called by the insertion event handler function. The insert hook takes the 
2060#	sequence generated by the \code{generateInsert} method throught the "seq" argument. The function
2061#	must return a Sequnece object, which will be inserted in the target sequence.
2062# } 
2063# 
2064# @synopsis 
2065# 
2066# \arguments{ 
2067# 	\item{this}{A GeneralInsertor object.} 
2068# 	\item{value}{A function object.} 
2069# 	\item{...}{Not used.} 
2070# } 
2071# 
2072# \value{ 
2073# 	The function object.
2074# } 
2075# 
2076# \examples{
2077#	# create a GeneralInsertor object
2078#	i<-GeneralInsertor(
2079#		rate=0.5,
2080#		propose.by=function(process){sample(c(5:10),1)}, # inserts between 5 and 10
2081#		template.seq=NucleotideSequence(length=5,processes=list(list(JC69())))
2082#	)
2083#	# set a dummy insert hook
2084#	setInsertHook(i,function(seq){return(seq)})
2085#	# set a new insert hook via virtual field
2086#	i$insertHook<-function(seq){
2087#		seq$processes<-list(list(GTR())) # replace the subsitution process
2088#		return(seq)
2089#	}
2090#	# get the insert hook via virtual field
2091#	i$insertHook
2092#	# get the insert hook
2093#	getInsertHook(i)
2094# } 
2095# 
2096# @author 
2097# 
2098# \seealso{ 
2099# 	@seeclass 
2100# } 
2101# 
2102#*/###########################################################################
2103setMethodS3(
2104	"setInsertHook", 
2105	class="GeneralInsertor", 
2106	function(
2107		this,
2108		value,
2109		...
2110	){
2111
2112		.checkWriteProtection(this);
2113		if(!is.Sequence(this$.template.seq)){
2114			throw("Cannot set insert hook because the template sequence is not defined!\n");
2115		}
2116		if(missing(value)) {
2117				throw("No new value provided!\n");	
2118		}
2119		else if(!is.function(value)){
2120			 throw("The insert hook must be a function.!\n");	
2121		}
2122		else if( length(intersect(names(formals(value)), "seq")) == 0 ){
2123      throw("The insert hook function must have a an argument named \"seq\"");
2124		}
2125		else if(!is.Sequence(value(generateInsert(this,length=1)))){
2126			throw("The insert hook function must return a Sequence object!\n");	
2127		} else {
2128			this$.insert.hook<-value;
2129		}
2130		return(this$.insert.hook);
2131
2132	},
2133	private=FALSE,
2134	protected=FALSE,
2135	overwrite=FALSE,
2136	conflict="warning",
2137	validators=getOption("R.methodsS3:validators:setMethodS3")
2138);
2139
2140
2141##	
2142## Method: summary
2143##	
2144###########################################################################/**
2145#
2146# @RdocMethod summary
2147#
2148# @title "Summarize the properties of an object"
2149#
2150# \description{
2151#       @get "title".
2152# }
2153#
2154# @synopsis
2155#
2156# \arguments{
2157#       \item{object}{An object}
2158#       \item{...}{Not used.}
2159# }
2160#
2161# \value{
2162#  Returns a PSRootSummary object.
2163# }
2164#
2165# \examples{
2166#
2167#       # create an object
2168#       a<-GeneralInsertor(rate=1)
2169#       # get a summary
2170#       summary(a)
2171# }
2172#
2173# @author
2174#
2175# \seealso{
2176#       @seeclass
2177# }
2178#
2179#*/###########################################################################
2180setMethodS3(
2181	"summary", 
2182	class="GeneralInsertor", 
2183	function(
2184		object,
2185		...
2186	){
2187
2188		.addSummaryNameId(object);
2189		object$.summary$"Accept window size"<-object$.accept.win;
2190		NextMethod();
2191
2192	},
2193	private=FALSE,
2194	protected=FALSE,
2195	overwrite=FALSE,
2196	conflict="warning",
2197	validators=getOption("R.methodsS3:validators:setMethodS3")
2198);
2199
2200#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
2201###########################################################################
2202# Class:GeneralDeletor
2203###…

Large files files are truncated, but you can click here to view the full file