[Distr-commits] r455 - branches/distr-2.2/pkg/utils pkg/utils
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Apr 9 14:13:07 CEST 2009
Author: ruckdeschel
Date: 2009-04-09 14:13:07 +0200 (Thu, 09 Apr 2009)
New Revision: 455
Added:
branches/distr-2.2/pkg/utils/compare.R
pkg/utils/compare.R
Modified:
branches/distr-2.2/pkg/utils/README-R-utils
pkg/utils/README-R-utils
Log:
new util compare() to compare two objects slot-wise, recursively...
Modified: branches/distr-2.2/pkg/utils/README-R-utils
===================================================================
--- branches/distr-2.2/pkg/utils/README-R-utils 2009-04-09 12:06:04 UTC (rev 454)
+++ branches/distr-2.2/pkg/utils/README-R-utils 2009-04-09 12:13:07 UTC (rev 455)
@@ -1,5 +1,5 @@
#####################################################
-# Howto to R - utils -- version 2.0 (170108)
+# Howto to R - utils -- version 2.2 (090409)
#####################################################
########### R - Utils
@@ -23,6 +23,16 @@
## develDir: development folder (absolute path)
## pattern: regexpr. for files to be sourced in
+### compare.R :
+#
+# compares (recursively over all slots / list elements)
+# two objects, i.e. it prints the corresponding slots of object1
+# directly on top of the corresponding slots of object2
+# Syntax
+
+compare(obj1, obj2, level = 0)
+## obj1,obj2: objects to compare; level: used internally for indentation
+
### setNewEmail.R
# automatically changes an e-mail adress in all (Text)-
Added: branches/distr-2.2/pkg/utils/compare.R
===================================================================
--- branches/distr-2.2/pkg/utils/compare.R (rev 0)
+++ branches/distr-2.2/pkg/utils/compare.R 2009-04-09 12:13:07 UTC (rev 455)
@@ -0,0 +1,57 @@
+### new util compare to compare structured S4 objects:
+
+compare <- function(obj1, obj2, level = 0) {
+# if(!isClass(class(obj1))||!isClass(class(obj2)))
+# stop("'isOldVersion()' only works for formal S4-Classes.")
+ if(! class(obj1)[1]==class(obj2)[1]){
+ cat(gettextf("Problem with classes: %s != %s\n",
+ class(obj1)[1], class(obj2)[1]))
+# stop("Classes must be identical.")
+ }
+ slotNames <- slotNames(obj1)
+ indent1 <- paste(rep(" ",max(level-1,0)),sep="",collapse="")
+ indent <- paste(rep(" ",level),sep="",collapse="")
+ cat(gettextf("%s-------------- Level %i -----------------\n",indent1,level))
+ ers <- sapply(slotNames, function(x){
+ if(!is.null(slot(obj1,x))&&!is.null(slot(obj2,x))){
+ cat(gettextf("%sComparing slot %s:\n", indent, x))
+ cat(gettextf("%s-------------- Level %i -----------------\n",indent, level+1))
+ }
+ cat(gettextf("%sSlot %s of object 1:\n", indent, x))
+ print(slot(obj1,x))
+ cat(gettextf("%sSlot %s of object 2:\n", indent, x))
+ print(slot(obj2,x))
+ if(is.list(slot(obj1,x))){
+ if(length(slot(obj1,x)))
+ sapply(1:length(slot(obj1,x)), function(i){
+ obj10 <- slot(obj1,x)[[i]]; obj20 <- slot(obj2,x)[[i]]
+ cat(gettextf("%sComparing element %i of slot list %s:\n", indent, i, x))
+ erg<- try(
+ compare(obj1=obj10,obj2=obj20, level = level + 1)
+ ,silent=TRUE)
+ if(is(erg,"try-error"))
+ cat(gettextf("!!!!! Classes of slot %s are not identical.\n",x))
+ }
+ )
+ }
+ else if(isClass(class(slot(obj1,x)))&&
+ class(slot(obj1,x))[1]!="numeric" &&
+ class(slot(obj1,x))[1]!="character" &&
+ class(slot(obj1,x))[1]!="matrix" &&
+ class(slot(obj1,x))[1]!="array" &&
+ class(slot(obj1,x))[1]!="call" &&
+ class(slot(obj1,x))[1]!="function"
+ ){
+# cat(gettextf("now trying %s\n", class(slot(obj1,x))[1]))
+ obj10 <- slot(obj1,x); obj20 <- slot(obj2,x)
+ erg<- try(
+ compare(obj1=obj10,obj2=obj20, level = level + 1)
+ ,silent=TRUE)
+ if(is(erg,"try-error"))
+ cat(gettextf("!!!!! Classes of slot %s are not identical.\n",x))
+ }
+
+ }
+ )
+ return(invisible(NULL))
+}
Modified: pkg/utils/README-R-utils
===================================================================
--- pkg/utils/README-R-utils 2009-04-09 12:06:04 UTC (rev 454)
+++ pkg/utils/README-R-utils 2009-04-09 12:13:07 UTC (rev 455)
@@ -1,5 +1,5 @@
#####################################################
-# Howto to R - utils -- version 2.0 (170108)
+# Howto to R - utils -- version 2.2 (090409)
#####################################################
########### R - Utils
@@ -23,6 +23,16 @@
## develDir: development folder (absolute path)
## pattern: regexpr. for files to be sourced in
+### compare.R :
+#
+# compares (recursively over all slots / list elements)
+# two objects, i.e. it prints the corresponding slots of object1
+# directly on top of the corresponding slots of object2
+# Syntax
+
+compare(obj1, obj2, level = 0)
+## obj1,obj2: objects to compare; level: used internally for indentation
+
### setNewEmail.R
# automatically changes an e-mail adress in all (Text)-
Added: pkg/utils/compare.R
===================================================================
--- pkg/utils/compare.R (rev 0)
+++ pkg/utils/compare.R 2009-04-09 12:13:07 UTC (rev 455)
@@ -0,0 +1,57 @@
+### new util compare to compare structured S4 objects:
+
+compare <- function(obj1, obj2, level = 0) {
+# if(!isClass(class(obj1))||!isClass(class(obj2)))
+# stop("'isOldVersion()' only works for formal S4-Classes.")
+ if(! class(obj1)[1]==class(obj2)[1]){
+ cat(gettextf("Problem with classes: %s != %s\n",
+ class(obj1)[1], class(obj2)[1]))
+# stop("Classes must be identical.")
+ }
+ slotNames <- slotNames(obj1)
+ indent1 <- paste(rep(" ",max(level-1,0)),sep="",collapse="")
+ indent <- paste(rep(" ",level),sep="",collapse="")
+ cat(gettextf("%s-------------- Level %i -----------------\n",indent1,level))
+ ers <- sapply(slotNames, function(x){
+ if(!is.null(slot(obj1,x))&&!is.null(slot(obj2,x))){
+ cat(gettextf("%sComparing slot %s:\n", indent, x))
+ cat(gettextf("%s-------------- Level %i -----------------\n",indent, level+1))
+ }
+ cat(gettextf("%sSlot %s of object 1:\n", indent, x))
+ print(slot(obj1,x))
+ cat(gettextf("%sSlot %s of object 2:\n", indent, x))
+ print(slot(obj2,x))
+ if(is.list(slot(obj1,x))){
+ if(length(slot(obj1,x)))
+ sapply(1:length(slot(obj1,x)), function(i){
+ obj10 <- slot(obj1,x)[[i]]; obj20 <- slot(obj2,x)[[i]]
+ cat(gettextf("%sComparing element %i of slot list %s:\n", indent, i, x))
+ erg<- try(
+ compare(obj1=obj10,obj2=obj20, level = level + 1)
+ ,silent=TRUE)
+ if(is(erg,"try-error"))
+ cat(gettextf("!!!!! Classes of slot %s are not identical.\n",x))
+ }
+ )
+ }
+ else if(isClass(class(slot(obj1,x)))&&
+ class(slot(obj1,x))[1]!="numeric" &&
+ class(slot(obj1,x))[1]!="character" &&
+ class(slot(obj1,x))[1]!="matrix" &&
+ class(slot(obj1,x))[1]!="array" &&
+ class(slot(obj1,x))[1]!="call" &&
+ class(slot(obj1,x))[1]!="function"
+ ){
+# cat(gettextf("now trying %s\n", class(slot(obj1,x))[1]))
+ obj10 <- slot(obj1,x); obj20 <- slot(obj2,x)
+ erg<- try(
+ compare(obj1=obj10,obj2=obj20, level = level + 1)
+ ,silent=TRUE)
+ if(is(erg,"try-error"))
+ cat(gettextf("!!!!! Classes of slot %s are not identical.\n",x))
+ }
+
+ }
+ )
+ return(invisible(NULL))
+}
More information about the Distr-commits
mailing list