attributes now inherited

[Steve Oncley]

Hi R-Developers,

After my message about a month ago concerning attributes being lost during
simple operations, Martin Maechler invited me to fix the code if I was in 
a hurry (especially for attributes in general).  We've just made the 
following changes here, which appear to implement the rules in the 
Blue Book (pg. 257) 

Enclosed is the output from "diff -c" from /R-0.61.1/src for:
main/arithmetic.c 	(calls my new routine based on Blue Book rules)
main/attrib.c 		(I added a new routine: copyMostAttrib)
main/complex.c 		(calls my new routine based on Blue Book rules)
include/Defn.h 		(one line addition to define copyMostAttrib)

We hope you will find this useful and install it in the next R release.

...Steve Oncley and Gordon Maclean
National Center for Atmospheric Research
Boulder, Colorado USA
(where the sun will soon set into the mountains)

**************************************************************************

*** arithmetic.c	Mon Nov 10 19:35:01 1997
--- /net/aster/R/src/main/arithmetic.c	Wed Apr  1 16:33:27 1998
***************
*** 428,433 ****
--- 428,443 ----
  	else
  		ans = allocVector(INTSXP, n);
  
+         /* copy attributes from longest argument */
+ 	if (n1 > n2)
+               copyMostAttrib(s1, ans);
+ 	else if (n1 == n2) {
+               copyMostAttrib(s2, ans);
+               copyMostAttrib(s1, ans);
+ 	}
+         else
+               copyMostAttrib(s2, ans);
+ 
  	if (n1 < 1 || n2 < 1) {
  		for (i = 0; i < n; i++)
  			INTEGER(ans)[i] = NA_INTEGER;
***************
*** 531,536 ****
--- 541,557 ----
  	PROTECT(s1);
  	PROTECT(s2);
  	ans = allocVector(REALSXP, n);
+ 
+         /* copy attributes from longest argument */
+ 	if (n1 > n2)
+               copyMostAttrib(s1, ans);
+ 	else if (n1 == n2) {
+               copyMostAttrib(s2, ans);
+               copyMostAttrib(s1, ans);
+ 	}
+         else
+               copyMostAttrib(s2, ans);
+ 
  	UNPROTECT(2);
  
  	if (n1 < 1 || n2 < 1) {

**************************************************************************

*** attrib.c	Mon Dec  8 02:36:53 1997
--- /net/aster/R/src/main/attrib.c	Wed Apr  1 16:43:28 1998
***************
*** 114,119 ****
--- 114,141 ----
  		return installAttrib(vec, name, val);
  }
  
+ SEXP copyMostAttrib(SEXP inp, SEXP ans)
+ {
+   /* This is called in the case of binary operations to copy most
+      attributes from (one of) the input arguments to the output.
+      Note that the Dim and Names attributes should have been assigned
+      elsewhere. */
+         SEXP s, t, u;
+ 
+ 	PROTECT(inp);
+ 	PROTECT(ans);
+ 
+ 	for (s=ATTRIB(inp); s!=R_NilValue; s=CDR(s)) {
+ 	  if ( (TAG(s) != R_NamesSymbol) &&
+ 	       (TAG(s) != R_DimSymbol) &&
+  	       (TAG(s) != R_DimNamesSymbol) ) {
+ 	    installAttrib(ans, TAG(s), CAR(s));
+ 	  }
+ 	}
+ 	UNPROTECT(2);
+         return;
+ }
+ 
  static SEXP installAttrib(SEXP vec, SEXP name, SEXP val)
  {
  	SEXP s, t;

**************************************************************************

*** complex.c	Wed Sep 17 22:37:02 1997
--- /net/aster/R/src/main/complex.c	Wed Apr  1 16:33:28 1998
***************
*** 104,109 ****
--- 104,121 ----
  	PROTECT(s1);
  	PROTECT(s2);
  	ans = allocVector(CPLXSXP, n);
+ 
+        /* copy attributes from longest argument */
+         if (n1 > n2)
+               copyMostAttrib(s1, ans);
+         else if (n1 == n2) {
+               copyMostAttrib(s2, ans);
+               copyMostAttrib(s1, ans);
+         }
+         else
+               copyMostAttrib(s2, ans);
+ 
+ 
  	UNPROTECT(2);
  
  	if (n1 < 1 || n2 < 1) {

**************************************************************************

*** Defn.h	Thu Jan  8 20:42:58 1998
--- /net/aster/R/src/include/Defn.h	Wed Apr  1 16:49:55 1998
***************
*** 459,464 ****
--- 459,465 ----
  SEXP cons(SEXP, SEXP);
  void copyListMatrix(SEXP, SEXP, int);
  void copyMatrix(SEXP, SEXP, int);
+ SEXP copyMostAttrib(SEXP, SEXP);
  void copyVector(SEXP, SEXP);
  SEXP CreateTag(SEXP);
  void CustomPrintValue(SEXP);
-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
r-devel mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !)  To: r-devel-request@stat.math.ethz.ch
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._