R/obj3_Fault.R

In nlr: Nonlinear Regression Modelling using Robust Methods

#+#########################################################################+
###    Fault object. store error conditions.                                \
###       Slots:                                                            /
###             Faults in program, depends on methods contains:            /
###                   FL: 'logical', if True (T) error, other Slots will   \
###                        be NULL, if False (F) no error method converged  \
###                   FN: 'integer' error number, if equal(0) zero no error, \ 
###                        otherwise is the number of error returned back by   \
###                        the method, some times the number shows an warning  |
###                        it means output exist i.e (FL=F), but some          |
###                        convergence problem occured. the number must be     |
###                        defined inside the method.                         /
###                   FT: Text of error, will be generated by each function. |
###                   FF: name of the function that the error is raise.      |
###
############################################################################+
setClass("Fault", representation(FL = "logical",FN = "numeric",FT="character",FF="character"))

Fault <- function(FL = F,FN=0,FT=NULL,FF=NULL,pnt=F){
	if(FN==0) {return(new("Fault",FL=FALSE,FN=FN,FT="",FF=""))}
	if( is.null(FT) & is.null(FF) ) 
		return( new( "Fault", FL=nlr::db.Fault$FL[nlr::db.Fault$FN==FN], 
								FN=FN,
								FT=nlr::db.Fault$FT[nlr::db.Fault$FN==FN],
								FF = nlr::db.Fault$FF[nlr::db.Fault$FN==FN]))
	if( is.null(FT) & (! is.null(FF)) ) {
		return( new( "Fault", FL=nlr::db.Fault$FL[nlr::db.Fault$FN==FN], 
								FN=FN,
								FT=nlr::db.Fault$FT[nlr::db.Fault$FN==FN],
								FF = FF))
							}
	if( (! is.null(FT)) & is.null(FF) ) 
		return( new( "Fault", FL=nlr::db.Fault$FL[nlr::db.Fault$FN==FN], 
								FN=FN,
								FT=FT,
								FF=nlr::db.Fault$FF[nlr::db.Fault$FN==FN]))
	Fault2 <- new("Fault",FL=FL,FN=FN,FF=FF) 
	if(pnt) print(Fault2)
	return(Fault2)
}

###################################################
##   Method $, Fault.
###################################################
setMethod("$","Fault",
	function(x,name){
		slot(x,name)
	} 
)

#+#################################################################+
#|                   End of the object 'Fault'                     |
#|                            28/09/2008                           |
#|                    Hossein Riazoshams, UPM, NSPEM               |
#+#################################################################+

###################################################
##   function is.Fault, return true if Fault object
##   or Fault list is true FF
###################################################
"is.Fault" <-	function(obj){
		if( class(obj)=="Fault") 
			if(obj$FL) return(T)
			else return(F)

		flt2 <- F
		if(.hasSlot(obj,"Fault")) 
			if(obj$Fault$FL) flt2 <- T
		
return(flt2)
	} 

###########################################################
##   function is.Faultwarn, return true if Fault object
##   or Fault list is true FF and or warning hapened
###########################################################
"is.Faultwarn" <-	function(obj){
		if( class(obj)=="Fault") 
			if(obj$FN != 0) return(T)

		flt2 <- F
		if(! is.null(obj$Fault)) 
			if(obj$Fault$FN != 0) flt2 <- T

    return(flt2)
	} 


###########################################################
##   function is.warn, return true if warning object
##   only is true if warning hapened, 
##   if error happen return false.
###########################################################
"is.Warn" <-	function(obj){
		if( class(obj)=="Fault") 
			if(obj$FN != 0 && ! obj$FL) return(T)
			else return(F)

    flt2 <- F
		if(! is.null(obj$Fault)) 
			if(obj$Fault$FN != 0 && ! obj$Fault$FL) flt2 <- T

return(flt2)
	}