r-gregmisc-users Mailing List for R gregmisc package (Page 35)

Brought to you by: warnes

r-gregmisc-users — Discussion list for R gregmisc packages (gplot, gmodels, gdata, gtools)

You can subscribe to this list here.

2006	Jan	Feb	Mar (12)	Apr (5)	May (3)	Jun (5)	Jul (2)	Aug (5)	Sep (7)	Oct (15)	Nov (34)	Dec (3)
2007	Jan (3)	Feb (16)	Mar (28)	Apr (5)	May	Jun (5)	Jul (9)	Aug (50)	Sep (29)	Oct (9)	Nov (25)	Dec (7)
2008	Jan (6)	Feb (4)	Mar (5)	Apr (8)	May (26)	Jun (11)	Jul	Aug (2)	Sep	Oct	Nov	Dec (9)
2009	Jan	Feb (1)	Mar	Apr (2)	May (26)	Jun	Jul (10)	Aug (6)	Sep	Oct (7)	Nov (3)	Dec (2)
2010	Jan (45)	Feb (11)	Mar	Apr (1)	May (8)	Jun (7)	Jul (3)	Aug (1)	Sep	Oct (1)	Nov (9)	Dec (1)
2011	Jan (2)	Feb	Mar	Apr (3)	May (1)	Jun	Jul	Aug (14)	Sep (29)	Oct (3)	Nov	Dec (3)
2012	Jan	Feb	Mar	Apr (7)	May (6)	Jun (59)	Jul	Aug (8)	Sep (21)	Oct	Nov	Dec
2013	Jan (1)	Feb	Mar (10)	Apr	May (18)	Jun (25)	Jul (18)	Aug (1)	Sep (6)	Oct (28)	Nov (4)	Dec (13)
2014	Jan (7)	Feb (5)	Mar (4)	Apr (36)	May (3)	Jun (7)	Jul (46)	Aug (14)	Sep (12)	Oct (2)	Nov	Dec (12)
2015	Jan (4)	Feb	Mar	Apr (80)	May (36)	Jun	Jul	Aug	Sep	Oct	Nov	Dec

Flat | Threaded

<< < 1 .. 33 34 35 36 37 .. 42 > >> (Page 35 of 42)

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1139] trunk/gplots/R/balloonplot.R

From: <wa...@us...> - 2007-08-14 18:13:27

Revision: 1139
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1139&view=rev
Author:   warnes
Date:     2007-08-14 11:11:33 -0700 (Tue, 14 Aug 2007)

Log Message:
-----------
Correct balloonplot.default to properly show specified x and y axis labels when explicitly provided

Modified Paths:
--------------
    trunk/gplots/R/balloonplot.R

Modified: trunk/gplots/R/balloonplot.R
===================================================================
--- trunk/gplots/R/balloonplot.R	2007-08-12 03:22:50 UTC (rev 1138)
+++ trunk/gplots/R/balloonplot.R	2007-08-14 18:11:33 UTC (rev 1139)
@@ -65,12 +65,6 @@
   else
      ynames <- names(y)
 
-  if(missing(xlab))
-    xlab <-  paste( xnames, collapse=", " )
-
-  if(missing(ylab))
-    ylab <-  paste( ynames, collapse=", " )
-  
   ####
   ## Handle arguments
   ####
@@ -358,26 +352,46 @@
   ####
   ## Column headers for row labels
   ####
-  text(
-       x=((1:length(ylabs))-0.5)*rowmar-0.5,
-       y=ny+0.5,
-       labels=ynames,
-       srt=colsrt,
-       font=2,
-       adj=c(0.5,0.0)
-       )
+  if(missing(ylab))
+    text(
+         x=((1:length(ylabs))-0.5)*rowmar-0.5,
+         y=ny+0.5,
+         labels=ynames,
+         srt=colsrt,
+         font=2,
+         adj=c(0.5,0.0)
+         )
+  else
+    text( 
+         x=((1:length(ylab))-0.5)*rowmar-0.5,
+         y=ny+0.5,
+         labels=ylab,
+         srt=colsrt,
+         font=2,
+         adj=c(0.5,0.0)
+         )
 
   ####
   ## Row headers for column labels
   ####
-  text(
-       x= nlabels.y*rowmar - 0.25 - strwidth(','),
-       y= ny + 0.75 + ((nlabels.x:1) - 1 + .5)*colmar,
-       labels=xnames,
-       srt=colsrt,
-       font=2,
-       adj=c(1,0.5)
-       )
+  if(missing(xlab))
+    text(
+         x= nlabels.y*rowmar - 0.25 - strwidth(','),
+         y= ny + 0.75 + ((nlabels.x:1) - 1 + .5)*colmar,
+         labels=xnames,
+         srt=colsrt,
+         font=2,
+         adj=c(1,0.5)
+         )
+  else
+    text(
+         x= nlabels.y*rowmar - 0.25 - strwidth(','),
+         y= ny + 0.75 + ((length(xlab):1) - 1 + .5)*colmar,
+         labels=xlab,
+         srt=colsrt,
+         font=2,
+         adj=c(1,0.5)
+         )
 
   ###
   ## add borders to row and column headers


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1138] trunk/SASxport

From: <wa...@us...> - 2007-08-12 03:22:53

Revision: 1138
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1138&view=rev
Author:   warnes
Date:     2007-08-11 20:22:50 -0700 (Sat, 11 Aug 2007)

Log Message:
-----------
More updates

Modified Paths:
--------------
    trunk/SASxport/DESCRIPTION
    trunk/SASxport/man/lookup.xport.Rd
    trunk/SASxport/src/cnxptiee.h
    trunk/SASxport/src/test_fields.c
    trunk/SASxport/src/writeSAS.h

Modified: trunk/SASxport/DESCRIPTION
===================================================================
--- trunk/SASxport/DESCRIPTION	2007-08-12 03:13:36 UTC (rev 1137)
+++ trunk/SASxport/DESCRIPTION	2007-08-12 03:22:50 UTC (rev 1138)
@@ -4,7 +4,10 @@
 Version: 0.99.1
 Date: 2007-07-28
 Author: Gregory R. Warnes <gr...@ra...>,
-        includes code from Frank E. Harrell, Jr.'s Hmisc package.   
+        includes code from Frank E. Harrell, Jr.'s Hmisc package,
+        and floating point conversion code from SAS techical support
+        document TS-140 "THE RECORD LAYOUT OF A DATA SET IN SAS"
+        TRANSPORT (XPORT) FORMAT.
 Maintainer: Gregory R. Warnes <gr...@ra...>
 Description: This package provides functions for both reading, listing
 	     contents of, and writing SAS xport format files. Reading
@@ -20,7 +23,6 @@
              Technical support contracts and other services for for R, this 
              package, and other packages are available from Random Technologies
              LLC <http://random-technologies-llc.com>.
-
 License: GPL 2.0 or later
 Imports: methods, foreign, chron
 

Modified: trunk/SASxport/man/lookup.xport.Rd
===================================================================
--- trunk/SASxport/man/lookup.xport.Rd	2007-08-12 03:13:36 UTC (rev 1137)
+++ trunk/SASxport/man/lookup.xport.Rd	2007-08-12 03:22:50 UTC (rev 1138)
@@ -10,12 +10,12 @@
 \usage{
 lookup.xport(file)
 \method{print}{lookup.xport}(x, ...)
-\method{summary}{lookup.xport}(x, ...)
+\method{summary}{lookup.xport}(object, ...)
 \method{print}{summary.lookup.xport}(x, ...)
 }
 \arguments{
   \item{file}{Character string specifying the name or URL of a SAS XPORT file.}
-  \item{x}{Object to be printed or summarized}
+  \item{x, object}{Object to be printed or summarized}
   \item{...}{Optional arguments}
 }
 \value{

Modified: trunk/SASxport/src/cnxptiee.h
===================================================================
--- trunk/SASxport/src/cnxptiee.h	2007-08-12 03:13:36 UTC (rev 1137)
+++ trunk/SASxport/src/cnxptiee.h	2007-08-12 03:22:50 UTC (rev 1138)
@@ -23,13 +23,13 @@
 int get_native(); 
 #endif 
 
-/* #ifdef BIG_ENDIAN */
-/* #define REVERSE(a,b)  */
-/* #endif  */
+#ifdef BIG_ENDIAN
+#define REVERSE(a,b)
+#endif
 
-/* #ifdef LITTLE_ENDIAN  */
-/* #define DEFINE_REVERSE */
-/* void REVERSE(); */
-/* #endif  */
+#ifdef LITTLE_ENDIAN
+#define DEFINE_REVERSE
+void REVERSE();
+#endif
 
 #endif /* CNXPTIEE */

Modified: trunk/SASxport/src/test_fields.c
===================================================================
--- trunk/SASxport/src/test_fields.c	2007-08-12 03:13:36 UTC (rev 1137)
+++ trunk/SASxport/src/test_fields.c	2007-08-12 03:22:50 UTC (rev 1138)
@@ -169,9 +169,5 @@
 
   test_blankCopy(BIG);
   test_zeroCopy(BIG);
-
-
-  /* test reverse */
-  test_reverse();
 }
   

Modified: trunk/SASxport/src/writeSAS.h
===================================================================
--- trunk/SASxport/src/writeSAS.h	2007-08-12 03:13:36 UTC (rev 1137)
+++ trunk/SASxport/src/writeSAS.h	2007-08-12 03:22:50 UTC (rev 1138)
@@ -37,19 +37,6 @@
 #define MISSING 0x2e000000  /* Standard SAS missing value: '.' */
 
 /*****
-  REVERSE macro, used as a wrapper for the reverse() function to avoid
-  compiling/calling it on little-endian.
- *****/
-
-#ifdef BIG_ENDIAN
-#  define REVERSE(a,b) reverse( (u_char*) a, (size_t) b)
-#elif defined(LITTLE_ENDIAN)
-#  define REVERSE(a,b) 
-#else 
-#  define REVERSE(a,b) reverse( (u_char*) a, (size_t) b)
-#endif
-
-/*****
  * Useful macro functions
  *****/
 
@@ -167,7 +154,4 @@
 
 void doTest();
 
-void reverse( u_char *intp, size_t size);
-
-
 #endif /* FIELDS_H */


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1137] trunk/SASxport/src

From: <wa...@us...> - 2007-08-12 03:13:37

Revision: 1137
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1137&view=rev
Author:   warnes
Date:     2007-08-11 20:13:36 -0700 (Sat, 11 Aug 2007)

Log Message:
-----------
Remove new stuff... use SAS's code instead

Removed Paths:
-------------
    trunk/SASxport/src/B8.h
    trunk/SASxport/src/IEEEtoIBM.c
    trunk/SASxport/src/MASKS.h
    trunk/SASxport/src/main.c
    trunk/SASxport/src/reverse.c

Deleted: trunk/SASxport/src/B8.h
===================================================================
--- trunk/SASxport/src/B8.h	2007-08-12 03:12:21 UTC (rev 1136)
+++ trunk/SASxport/src/B8.h	2007-08-12 03:13:36 UTC (rev 1137)
@@ -1,60 +0,0 @@
-/* Binary constant generator macro
-By Tom Torfs - donated to the public domain
-*/
-
-#include <sys/types.h>
-
-
-/* All macro's evaluate to compile-time constants */
-
-/* *** helper macros *** /
-
-/* turn a numeric literal into a hex constant
-(avoids problems with leading zeroes)
-8-bit constants max value 0x11111111, always fits in unsigned long
-*/
-#define HEX__(n) 0x##n##LU
-
-/* 8-bit conversion function */
-#define B8__(x) ((x&0x0000000FLU)?1:0) \
-+((x&0x000000F0LU)?2:0) \
-+((x&0x00000F00LU)?4:0) \
-+((x&0x0000F000LU)?8:0) \
-+((x&0x000F0000LU)?16:0) \
-+((x&0x00F00000LU)?32:0) \
-+((x&0x0F000000LU)?64:0) \
-+((x&0xF0000000LU)?128:0)
-
-/* *** user macros *** /
-
-/* for upto 8-bit binary constants */
-#define B8(d) ((unsigned char)B8__(HEX__(d)))
-
-/* for upto 16-bit binary constants, MSB first */
-#define B16(dmsb,dlsb) (((unsigned short)B8(dmsb)<<8) \
-+ B8(dlsb))
-
-/* for upto 32-bit binary constants, MSB first */
-#define B32(dmsb,db2,db3,dlsb) ( \
-+ ((unsigned long)B8(dmsb)<<24) \
-+ ((unsigned long)B8(db2)<<16) \
-+ ((unsigned long)B8(db3)<<8) \
-+ B8(dlsb))
-
-/* for upto 32-bit binary constants, MSB first */
-#define B64(dmsb,db2,db3,db4,db5,db6,db7,dlsb) ( \
-+ ((unsigned int64_t)B8(dmsb<<56) \
-+ ((unsigned int64_t)B8(db2)<<48) \
-+ ((unsigned int64_t)B8(db3)<<40) \
-+ ((unsigned int64_t)B8(db4 <<32) \
-+ ((unsigned int64_t)B8(dm5)<<24) \
-+ ((unsigned int64_t)B8(db6)<<16) \
-+ ((unsigned int64_t)B8(db7)<<8 ) \
-+ B8(dlsb))
-
-
-/* Sample usage:
-B8(01010101) = 85
-B16(10101010,01010101) = 43605
-B32(10000000,11111111,10101010,01010101) = 2164238933
-*/

Deleted: trunk/SASxport/src/IEEEtoIBM.c
===================================================================
--- trunk/SASxport/src/IEEEtoIBM.c	2007-08-12 03:12:21 UTC (rev 1136)
+++ trunk/SASxport/src/IEEEtoIBM.c	2007-08-12 03:13:36 UTC (rev 1137)
@@ -1,109 +0,0 @@
-//#include "writeSAS.h"
-
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#import  <assert.h>
-#import  <sys/types.h>
-
-typedef struct {                    /* IBM floating point format */
-  unsigned sign    :   1;   /* Sign bit */
-  unsigned exponent:   7;   /* Exponent */
-  //unsigned fraction:  56;   /* Fraction */
-  unsigned fraction1:  24;    /* Top half of fraction */
-  unsigned fraction2:  32;    /* Lower half of fraction */
-} IBM_fp_struct;
-
-
-typedef struct {                    /* IEEE floating point format */
-  unsigned sign    :   1;   /* Sign bit */
-  unsigned exponent:  11;   /* Exponent */
-  //  unsigned fraction:  52;   /* Fraction */
-  unsigned fraction1:  20;    /* Top half of fraction */
-  unsigned fraction2:  32;    /* Lower half of fraction */
-} IEEE_fp_struct;
-
-
-int IEEEtoIBM(double *ieee, double *ibm )
-{
-  IEEE_fp_struct *ieee_fp = (IEEE_fp_struct*) ieee;
-  IBM_fp_struct  *ibm_fp  = (IBM_fp_struct* ) ibm;
-  int64_t        sign;
-  int64_t        exponent;
-  int64_t        fraction;
-  short          low_exp_bits;
-  
-  /*** Extract Pieces ***/
-  //  Sign     = Ieee & Ieee_Sign;
-  //  Exponent = *Ieee & Ieee_Exp;
-  //  Fraction = *Ieee & Ieee_Frac;
-
-  printf("1\n");
-
-  /*** copy IEEE sign to IBM sign ***/
-  ibm_fp->sign = ieee_fp->sign;
-
-  printf("2\n");
-
-  /*** convert IEEE exponent to IBM exponent ***/
-  exponent = ieee_fp->exponent;
-
-  printf("3\n");
-
-  /* store lowest 2 bits from exponent */
-  low_exp_bits = exponent % 16;   
-  
-
-  printf("4\n");
-
-  /* divide exponent by 4 to get from IEEE pow(2) exponent to IBM pow(16) exponent  */  
-  exponent = exponent >> 2;
-
-  printf("5\n");
-
-  
-  /* put it into the return value */
-  ibm_fp->exponent = exponent;
-
-  printf("6\n");
-
-
-  /*** convert IEEE fraction to IBM fraction */
-  fraction = ((int64_t) ieee_fp->fraction1 ) << 32 | ((int64_t) ieee_fp->fraction2);
-
-  printf("7\n");
-
-
-  /* shift left by low order bits lost from exponent */
-  fraction = fraction  <<   (low_exp_bits && 0x03);
-
-
-  printf("8\n");
-
-  /* add leading 1 bit */
-  fraction >> 1;
-  fraction = fraction | ( ((int64_t) 1) <<55 );
-
-  printf("9\n");
-
-
-  ibm_fp->fraction1 = (int32_t) (fraction >> 32) | 0x0FFFFF;
-  ibm_fp->fraction2 = (int32_t) fraction;
-
-
-  printf("10\n");
-
-  
-  char *buf= (char*) ibm;
-  char tmp;
-  int i;
-  for(i=0; i<8; i++)
-    {
-      tmp = buf[7-i];
-      buf[7-i] = buf[i];
-      buf[i] = tmp;
-    }
-
-  return 0;
-}
-

Deleted: trunk/SASxport/src/MASKS.h
===================================================================
--- trunk/SASxport/src/MASKS.h	2007-08-12 03:12:21 UTC (rev 1136)
+++ trunk/SASxport/src/MASKS.h	2007-08-12 03:13:36 UTC (rev 1137)
@@ -1,23 +0,0 @@
-/* Masks for IBM fields  */
-#define IBM_SIGN  B64(10000000, 0000000, 0000000, 00000000, \
-                      00000000, 0000000, 0000000, 00000000)
-
-#define IBM_EXP   B64(01111111, 0000000, 0000000, 00000000, \
-                      00000000, 0000000, 0000000, 00000000)
-
-#define IBM_FRAC  B64(00000000, 1111111, 1111111, 11111111, \
-		      11111111, 1111111, 1111111, 11111111)
-
-#define IBM_FRAC_MSB B64(00000000, 1000000, 0000000, 00000000, \
-                         00000000, 0000000, 0000000, 00000000)
-
-/* Masks for IEEE fields  */
-#define IEEE_SIGN B64(10000000, 0000000, 0000000, 00000000, \
-                      00000000, 0000000, 0000000, 00000000)
-
-#define IEEE_EXP  B64(01111111, 1111000, 0000000, 00000000, \
-                      00000000, 0000000, 0000000, 00000000)
-
-#define IEEE_FRAC B64(00000000, 0000111, 1111111, 11111111, \
-		      11111111, 1111111, 1111111, 11111111)
-

Deleted: trunk/SASxport/src/main.c
===================================================================
--- trunk/SASxport/src/main.c	2007-08-12 03:12:21 UTC (rev 1136)
+++ trunk/SASxport/src/main.c	2007-08-12 03:13:36 UTC (rev 1137)
@@ -1,55 +0,0 @@
-#include <math.h>
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#import  <assert.h>
-#import  <sys/types.h>
-
-
-extern int cnxptiee(char *from, int fromtype, char *to, int totype);
-int IEEEtoIBM(double *ieee, double *ibm );
-
-int main(int argc, char *argv)
-{
-  double ieee;
-  double ibm_sas, ieee_sas;
-  double ibm_our, ieee_our;
-  char *ibm_sas_c = (char*) &ibm_sas;
-  char *ibm_our_c = (char*) &ibm_our;
-
-
-  for(int i=0; i<10; i++)
-    {
-      ieee = pow(2.0, ((double) i)) + 1.0 + 1.0 / ( ((double) i) + 1.0);
-
-      /* from ieee to ibm, SAS code */
-      cnxptiee( (char*) &ieee, 0, (char*) &ibm_sas, 1 );
-
-      /* and back again, SAS code */
-      cnxptiee( (char*) &ibm_sas, 1, (char*) &ieee_sas, 0  ); 
-     
-
-      /* from ieee to ibm, our code */
-      IEEEtoIBM( &ieee, &ibm_our );
-
-      /* and back again, SAS code */
-      cnxptiee( (char*) &ibm_our, 1, (char*) &ieee_our, 0  );
-
-
-      printf("i=%5d, ieee=%10f, ieee_sas=%10f ieee_our=%10f \n", i, 
-	     ieee, ieee_sas, ieee_our);
-
-      for(int index=0; index<8; index++)
-	{
-	  printf("  ");
-	  printf("%2x ", ibm_sas_c[index]);
-	  printf("%2x ", ibm_our_c[index]);
-	  printf("\n");
-	}
-      printf("\n");
-
-    }
-
-  return 0;
-}
-

Deleted: trunk/SASxport/src/reverse.c
===================================================================
--- trunk/SASxport/src/reverse.c	2007-08-12 03:12:21 UTC (rev 1136)
+++ trunk/SASxport/src/reverse.c	2007-08-12 03:13:36 UTC (rev 1137)
@@ -1,83 +0,0 @@
-#include "writeSAS.h"
-
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#import  <assert.h>
-#import  <sys/types.h>
-
-/* reverse: convert current byte order to little endian */
-void reverse( u_char *intp, size_t size)
-{
-  static u_char endianTest[2] =   {0x01,0x00};
-  size_t i;
-  u_char tmp;
-
-#if !defined(BIG_ENDIAN) && !defined(LITTLE_ENDIAN)
-  /* Test if we are on a big endian or little endian platform */
-  if( (short) *endianTest == 1 ) 
-    {  
-      /* Little Endian */
-      /* Do nothing    */
-      return;  
-    }
-#endif
-
-  /* Big Endian */
-  /* Swap bytes */
-  for(i=0; i < size/2; i++)
-    {
-      tmp = (u_char) intp[i];
-      intp[i] = intp[size-i-1];
-      intp[size-i] = tmp;
-    }
-  
-  return;
-}
-
-
-/* test code */
-void test_reverse()
-{
-  u_char  byte_pattern[1] = { 0x00 };
-  u_char  byte_value      = 0x00;
-  
-  u_char  short_pattern[2] = { 0x00, 0x01 };  /* NB: little endian byte pattern */
-  short   short_value       = 0x0100;          /* NB: hex is written big endian */
-  
-  u_char  int_pattern[4]   = { 0x0, 0x01, 0x02, 0x03 };
-  int     int_value        = 0x03020100; 
-
-  u_char  long_pattern[4]  = { 0x0, 0x01, 0x02, 0x03 };
-  long    long_value       = 0x03020100; 
-
-  /* Do the reverse, then test */
-
-  /* byte */
-  REVERSE( &byte_value, sizeof(u_char) );
-  assert( (u_char) *byte_pattern == byte_value );
-
-  /* short */
-  REVERSE( &short_value, sizeof(short) );
-  assert( *((short *) short_pattern) == short_value );
-
-  /* int */
-  REVERSE( &int_value, sizeof(int) );
-  assert( *((int *) int_pattern) == int_value );
-
-  /* long */
-  REVERSE( &long_value, sizeof(long) );
-  assert( *((long*) long_pattern) == long_value );
-
-}
-
-
-#ifdef DO_TEST
-int main(int argc, u_char *argv)
-{
-  test_reverse();
-}
-
-
-
-#endif


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1136] trunk/SASxport/src

From: <wa...@us...> - 2007-08-12 03:12:44

Revision: 1136
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1136&view=rev
Author:   warnes
Date:     2007-08-11 20:12:21 -0700 (Sat, 11 Aug 2007)

Log Message:
-----------
1st attempt at rewriting cnxptiee.[ch]

Modified Paths:
--------------
    trunk/SASxport/src/cnxptiee.h
    trunk/SASxport/src/test_fields.c
    trunk/SASxport/src/writeSAS.h

Added Paths:
-----------
    trunk/SASxport/src/B8.h
    trunk/SASxport/src/IEEEtoIBM.c
    trunk/SASxport/src/MASKS.h
    trunk/SASxport/src/main.c
    trunk/SASxport/src/reverse.c

Added: trunk/SASxport/src/B8.h
===================================================================
--- trunk/SASxport/src/B8.h	                        (rev 0)
+++ trunk/SASxport/src/B8.h	2007-08-12 03:12:21 UTC (rev 1136)
@@ -0,0 +1,60 @@
+/* Binary constant generator macro
+By Tom Torfs - donated to the public domain
+*/
+
+#include <sys/types.h>
+
+
+/* All macro's evaluate to compile-time constants */
+
+/* *** helper macros *** /
+
+/* turn a numeric literal into a hex constant
+(avoids problems with leading zeroes)
+8-bit constants max value 0x11111111, always fits in unsigned long
+*/
+#define HEX__(n) 0x##n##LU
+
+/* 8-bit conversion function */
+#define B8__(x) ((x&0x0000000FLU)?1:0) \
++((x&0x000000F0LU)?2:0) \
++((x&0x00000F00LU)?4:0) \
++((x&0x0000F000LU)?8:0) \
++((x&0x000F0000LU)?16:0) \
++((x&0x00F00000LU)?32:0) \
++((x&0x0F000000LU)?64:0) \
++((x&0xF0000000LU)?128:0)
+
+/* *** user macros *** /
+
+/* for upto 8-bit binary constants */
+#define B8(d) ((unsigned char)B8__(HEX__(d)))
+
+/* for upto 16-bit binary constants, MSB first */
+#define B16(dmsb,dlsb) (((unsigned short)B8(dmsb)<<8) \
++ B8(dlsb))
+
+/* for upto 32-bit binary constants, MSB first */
+#define B32(dmsb,db2,db3,dlsb) ( \
++ ((unsigned long)B8(dmsb)<<24) \
++ ((unsigned long)B8(db2)<<16) \
++ ((unsigned long)B8(db3)<<8) \
++ B8(dlsb))
+
+/* for upto 32-bit binary constants, MSB first */
+#define B64(dmsb,db2,db3,db4,db5,db6,db7,dlsb) ( \
++ ((unsigned int64_t)B8(dmsb<<56) \
++ ((unsigned int64_t)B8(db2)<<48) \
++ ((unsigned int64_t)B8(db3)<<40) \
++ ((unsigned int64_t)B8(db4 <<32) \
++ ((unsigned int64_t)B8(dm5)<<24) \
++ ((unsigned int64_t)B8(db6)<<16) \
++ ((unsigned int64_t)B8(db7)<<8 ) \
++ B8(dlsb))
+
+
+/* Sample usage:
+B8(01010101) = 85
+B16(10101010,01010101) = 43605
+B32(10000000,11111111,10101010,01010101) = 2164238933
+*/

Added: trunk/SASxport/src/IEEEtoIBM.c
===================================================================
--- trunk/SASxport/src/IEEEtoIBM.c	                        (rev 0)
+++ trunk/SASxport/src/IEEEtoIBM.c	2007-08-12 03:12:21 UTC (rev 1136)
@@ -0,0 +1,109 @@
+//#include "writeSAS.h"
+
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#import  <assert.h>
+#import  <sys/types.h>
+
+typedef struct {                    /* IBM floating point format */
+  unsigned sign    :   1;   /* Sign bit */
+  unsigned exponent:   7;   /* Exponent */
+  //unsigned fraction:  56;   /* Fraction */
+  unsigned fraction1:  24;    /* Top half of fraction */
+  unsigned fraction2:  32;    /* Lower half of fraction */
+} IBM_fp_struct;
+
+
+typedef struct {                    /* IEEE floating point format */
+  unsigned sign    :   1;   /* Sign bit */
+  unsigned exponent:  11;   /* Exponent */
+  //  unsigned fraction:  52;   /* Fraction */
+  unsigned fraction1:  20;    /* Top half of fraction */
+  unsigned fraction2:  32;    /* Lower half of fraction */
+} IEEE_fp_struct;
+
+
+int IEEEtoIBM(double *ieee, double *ibm )
+{
+  IEEE_fp_struct *ieee_fp = (IEEE_fp_struct*) ieee;
+  IBM_fp_struct  *ibm_fp  = (IBM_fp_struct* ) ibm;
+  int64_t        sign;
+  int64_t        exponent;
+  int64_t        fraction;
+  short          low_exp_bits;
+  
+  /*** Extract Pieces ***/
+  //  Sign     = Ieee & Ieee_Sign;
+  //  Exponent = *Ieee & Ieee_Exp;
+  //  Fraction = *Ieee & Ieee_Frac;
+
+  printf("1\n");
+
+  /*** copy IEEE sign to IBM sign ***/
+  ibm_fp->sign = ieee_fp->sign;
+
+  printf("2\n");
+
+  /*** convert IEEE exponent to IBM exponent ***/
+  exponent = ieee_fp->exponent;
+
+  printf("3\n");
+
+  /* store lowest 2 bits from exponent */
+  low_exp_bits = exponent % 16;   
+  
+
+  printf("4\n");
+
+  /* divide exponent by 4 to get from IEEE pow(2) exponent to IBM pow(16) exponent  */  
+  exponent = exponent >> 2;
+
+  printf("5\n");
+
+  
+  /* put it into the return value */
+  ibm_fp->exponent = exponent;
+
+  printf("6\n");
+
+
+  /*** convert IEEE fraction to IBM fraction */
+  fraction = ((int64_t) ieee_fp->fraction1 ) << 32 | ((int64_t) ieee_fp->fraction2);
+
+  printf("7\n");
+
+
+  /* shift left by low order bits lost from exponent */
+  fraction = fraction  <<   (low_exp_bits && 0x03);
+
+
+  printf("8\n");
+
+  /* add leading 1 bit */
+  fraction >> 1;
+  fraction = fraction | ( ((int64_t) 1) <<55 );
+
+  printf("9\n");
+
+
+  ibm_fp->fraction1 = (int32_t) (fraction >> 32) | 0x0FFFFF;
+  ibm_fp->fraction2 = (int32_t) fraction;
+
+
+  printf("10\n");
+
+  
+  char *buf= (char*) ibm;
+  char tmp;
+  int i;
+  for(i=0; i<8; i++)
+    {
+      tmp = buf[7-i];
+      buf[7-i] = buf[i];
+      buf[i] = tmp;
+    }
+
+  return 0;
+}
+

Added: trunk/SASxport/src/MASKS.h
===================================================================
--- trunk/SASxport/src/MASKS.h	                        (rev 0)
+++ trunk/SASxport/src/MASKS.h	2007-08-12 03:12:21 UTC (rev 1136)
@@ -0,0 +1,23 @@
+/* Masks for IBM fields  */
+#define IBM_SIGN  B64(10000000, 0000000, 0000000, 00000000, \
+                      00000000, 0000000, 0000000, 00000000)
+
+#define IBM_EXP   B64(01111111, 0000000, 0000000, 00000000, \
+                      00000000, 0000000, 0000000, 00000000)
+
+#define IBM_FRAC  B64(00000000, 1111111, 1111111, 11111111, \
+		      11111111, 1111111, 1111111, 11111111)
+
+#define IBM_FRAC_MSB B64(00000000, 1000000, 0000000, 00000000, \
+                         00000000, 0000000, 0000000, 00000000)
+
+/* Masks for IEEE fields  */
+#define IEEE_SIGN B64(10000000, 0000000, 0000000, 00000000, \
+                      00000000, 0000000, 0000000, 00000000)
+
+#define IEEE_EXP  B64(01111111, 1111000, 0000000, 00000000, \
+                      00000000, 0000000, 0000000, 00000000)
+
+#define IEEE_FRAC B64(00000000, 0000111, 1111111, 11111111, \
+		      11111111, 1111111, 1111111, 11111111)
+

Modified: trunk/SASxport/src/cnxptiee.h
===================================================================
--- trunk/SASxport/src/cnxptiee.h	2007-08-11 23:48:34 UTC (rev 1135)
+++ trunk/SASxport/src/cnxptiee.h	2007-08-12 03:12:21 UTC (rev 1136)
@@ -23,13 +23,13 @@
 int get_native(); 
 #endif 
 
-#ifdef BIG_ENDIAN
-#define REVERSE(a,b) 
-#endif 
+/* #ifdef BIG_ENDIAN */
+/* #define REVERSE(a,b)  */
+/* #endif  */
 
-#ifdef LITTLE_ENDIAN 
-#define DEFINE_REVERSE
-void REVERSE();
-#endif 
+/* #ifdef LITTLE_ENDIAN  */
+/* #define DEFINE_REVERSE */
+/* void REVERSE(); */
+/* #endif  */
 
 #endif /* CNXPTIEE */

Added: trunk/SASxport/src/main.c
===================================================================
--- trunk/SASxport/src/main.c	                        (rev 0)
+++ trunk/SASxport/src/main.c	2007-08-12 03:12:21 UTC (rev 1136)
@@ -0,0 +1,55 @@
+#include <math.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#import  <assert.h>
+#import  <sys/types.h>
+
+
+extern int cnxptiee(char *from, int fromtype, char *to, int totype);
+int IEEEtoIBM(double *ieee, double *ibm );
+
+int main(int argc, char *argv)
+{
+  double ieee;
+  double ibm_sas, ieee_sas;
+  double ibm_our, ieee_our;
+  char *ibm_sas_c = (char*) &ibm_sas;
+  char *ibm_our_c = (char*) &ibm_our;
+
+
+  for(int i=0; i<10; i++)
+    {
+      ieee = pow(2.0, ((double) i)) + 1.0 + 1.0 / ( ((double) i) + 1.0);
+
+      /* from ieee to ibm, SAS code */
+      cnxptiee( (char*) &ieee, 0, (char*) &ibm_sas, 1 );
+
+      /* and back again, SAS code */
+      cnxptiee( (char*) &ibm_sas, 1, (char*) &ieee_sas, 0  ); 
+     
+
+      /* from ieee to ibm, our code */
+      IEEEtoIBM( &ieee, &ibm_our );
+
+      /* and back again, SAS code */
+      cnxptiee( (char*) &ibm_our, 1, (char*) &ieee_our, 0  );
+
+
+      printf("i=%5d, ieee=%10f, ieee_sas=%10f ieee_our=%10f \n", i, 
+	     ieee, ieee_sas, ieee_our);
+
+      for(int index=0; index<8; index++)
+	{
+	  printf("  ");
+	  printf("%2x ", ibm_sas_c[index]);
+	  printf("%2x ", ibm_our_c[index]);
+	  printf("\n");
+	}
+      printf("\n");
+
+    }
+
+  return 0;
+}
+

Added: trunk/SASxport/src/reverse.c
===================================================================
--- trunk/SASxport/src/reverse.c	                        (rev 0)
+++ trunk/SASxport/src/reverse.c	2007-08-12 03:12:21 UTC (rev 1136)
@@ -0,0 +1,83 @@
+#include "writeSAS.h"
+
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#import  <assert.h>
+#import  <sys/types.h>
+
+/* reverse: convert current byte order to little endian */
+void reverse( u_char *intp, size_t size)
+{
+  static u_char endianTest[2] =   {0x01,0x00};
+  size_t i;
+  u_char tmp;
+
+#if !defined(BIG_ENDIAN) && !defined(LITTLE_ENDIAN)
+  /* Test if we are on a big endian or little endian platform */
+  if( (short) *endianTest == 1 ) 
+    {  
+      /* Little Endian */
+      /* Do nothing    */
+      return;  
+    }
+#endif
+
+  /* Big Endian */
+  /* Swap bytes */
+  for(i=0; i < size/2; i++)
+    {
+      tmp = (u_char) intp[i];
+      intp[i] = intp[size-i-1];
+      intp[size-i] = tmp;
+    }
+  
+  return;
+}
+
+
+/* test code */
+void test_reverse()
+{
+  u_char  byte_pattern[1] = { 0x00 };
+  u_char  byte_value      = 0x00;
+  
+  u_char  short_pattern[2] = { 0x00, 0x01 };  /* NB: little endian byte pattern */
+  short   short_value       = 0x0100;          /* NB: hex is written big endian */
+  
+  u_char  int_pattern[4]   = { 0x0, 0x01, 0x02, 0x03 };
+  int     int_value        = 0x03020100; 
+
+  u_char  long_pattern[4]  = { 0x0, 0x01, 0x02, 0x03 };
+  long    long_value       = 0x03020100; 
+
+  /* Do the reverse, then test */
+
+  /* byte */
+  REVERSE( &byte_value, sizeof(u_char) );
+  assert( (u_char) *byte_pattern == byte_value );
+
+  /* short */
+  REVERSE( &short_value, sizeof(short) );
+  assert( *((short *) short_pattern) == short_value );
+
+  /* int */
+  REVERSE( &int_value, sizeof(int) );
+  assert( *((int *) int_pattern) == int_value );
+
+  /* long */
+  REVERSE( &long_value, sizeof(long) );
+  assert( *((long*) long_pattern) == long_value );
+
+}
+
+
+#ifdef DO_TEST
+int main(int argc, u_char *argv)
+{
+  test_reverse();
+}
+
+
+
+#endif

Modified: trunk/SASxport/src/test_fields.c
===================================================================
--- trunk/SASxport/src/test_fields.c	2007-08-11 23:48:34 UTC (rev 1135)
+++ trunk/SASxport/src/test_fields.c	2007-08-12 03:12:21 UTC (rev 1136)
@@ -151,6 +151,8 @@
   return 0;
 }
 
+
+
 void doTest()
 {
   /* small buffer */
@@ -167,5 +169,9 @@
 
   test_blankCopy(BIG);
   test_zeroCopy(BIG);
+
+
+  /* test reverse */
+  test_reverse();
 }
   

Modified: trunk/SASxport/src/writeSAS.h
===================================================================
--- trunk/SASxport/src/writeSAS.h	2007-08-11 23:48:34 UTC (rev 1135)
+++ trunk/SASxport/src/writeSAS.h	2007-08-12 03:12:21 UTC (rev 1136)
@@ -27,7 +27,9 @@
 
 #include <R.h>
 #include <Rinternals.h>
+#include <sys/types.h>
 
+
 /*****
  * Useful constants 
  *****/
@@ -35,6 +37,19 @@
 #define MISSING 0x2e000000  /* Standard SAS missing value: '.' */
 
 /*****
+  REVERSE macro, used as a wrapper for the reverse() function to avoid
+  compiling/calling it on little-endian.
+ *****/
+
+#ifdef BIG_ENDIAN
+#  define REVERSE(a,b) reverse( (u_char*) a, (size_t) b)
+#elif defined(LITTLE_ENDIAN)
+#  define REVERSE(a,b) 
+#else 
+#  define REVERSE(a,b) reverse( (u_char*) a, (size_t) b)
+#endif
+
+/*****
  * Useful macro functions
  *****/
 
@@ -152,4 +167,7 @@
 
 void doTest();
 
+void reverse( u_char *intp, size_t size);
+
+
 #endif /* FIELDS_H */


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1135] trunk/SASxport/R/read.xport.R

From: <wa...@us...> - 2007-08-11 23:48:36

Revision: 1135
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1135&view=rev
Author:   warnes
Date:     2007-08-11 16:48:34 -0700 (Sat, 11 Aug 2007)

Log Message:
-----------
Explicitly check file header

Modified Paths:
--------------
    trunk/SASxport/R/read.xport.R

Modified: trunk/SASxport/R/read.xport.R
===================================================================
--- trunk/SASxport/R/read.xport.R	2007-08-11 00:03:52 UTC (rev 1134)
+++ trunk/SASxport/R/read.xport.R	2007-08-11 23:48:34 UTC (rev 1135)
@@ -36,6 +36,13 @@
         file <- tf
       }
 
+    scat("Checking if the specified file has the appropriate header")
+    xport.file.header <- "HEADER RECORD*******LIBRARY HEADER RECORD!!!!!!!000000000000000000000000000000  "
+    file.header <- readBin( file, what=character(0), n=1, size=nchar(xport.file.header) )
+    file.header <- substr(file.header, start=1, stop=nchar(xport.file.header) )
+    if( !identical(xport.file.header, file.header) )
+      stop("The specified file does not start with a SAS xport file header!")
+           
     scat("Extracting data file information...")
     dsinfo <- foreign:::lookup.xport(file)
 


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1134] trunk/SASxport

From: <wa...@us...> - 2007-08-11 00:03:56

Revision: 1134
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1134&view=rev
Author:   warnes
Date:     2007-08-10 17:03:52 -0700 (Fri, 10 Aug 2007)

Log Message:
-----------
Improve package description

Modified Paths:
--------------
    trunk/SASxport/DESCRIPTION
    trunk/SASxport/man/SASxport-package.Rd

Modified: trunk/SASxport/DESCRIPTION
===================================================================
--- trunk/SASxport/DESCRIPTION	2007-08-09 23:29:01 UTC (rev 1133)
+++ trunk/SASxport/DESCRIPTION	2007-08-11 00:03:52 UTC (rev 1134)
@@ -6,14 +6,21 @@
 Author: Gregory R. Warnes <gr...@ra...>,
         includes code from Frank E. Harrell, Jr.'s Hmisc package.   
 Maintainer: Gregory R. Warnes <gr...@ra...>
-Description: This package provides functions to read, list contents of, and  
-             write SAS export files.  This package was created by Random 
-             Technologies LLC <http://random-technologies-llc.com> with funding
-             by Metrum Institute <http://metruminstitute.org>. 
+Description: This package provides functions for both reading, listing
+	     contents of, and writing SAS xport format files. Reading
+	     and writing of both individual and sets of data frames
+	     are supported.   Further, a mechanism has been provided
+	     for customizing how variables of different data types are
+	     stored.
+	     .
+	     This package was created by Random Technologies LLC
+	     <http://random-technologies-llc.com> with funding by
+	     Metrum Institute <http://metruminstitute.org>.  
              .
              Technical support contracts and other services for for R, this 
              package, and other packages are available from Random Technologies
              LLC <http://random-technologies-llc.com>.
+
 License: GPL 2.0 or later
 Imports: methods, foreign, chron
 

Modified: trunk/SASxport/man/SASxport-package.Rd
===================================================================
--- trunk/SASxport/man/SASxport-package.Rd	2007-08-09 23:29:01 UTC (rev 1133)
+++ trunk/SASxport/man/SASxport-package.Rd	2007-08-11 00:03:52 UTC (rev 1134)
@@ -3,39 +3,67 @@
 \alias{SASxport}
 \docType{package}
 \title{
-Read and write SAS export files
+  Read and write SAS export files
 }
 \description{
-This package provides functions to read, list contents of,
-and write SAS export files.
+  This package provides functions to read, list contents of, and write
+  SAS export files.
 }
 \details{
 
-This package was created by Random
-Technologies LLC <http://random-technologies-llc.com> with funding by
-Metrum Institute <http://metruminstitute.org>.
+  The read.xport function for reading xport files augments the
+  functionality of the read.xport function provided in the "recommended" 
+  package 'foreign' with additional features borrowed from Frank Harrell's
+  sasxport.get() in the 'Hmisc' package.  Namely, variables are properly
+  coerced into the types specified by the format field. All standard
+  numeric and string formats are supported  automatically, while
+  user-defined formats are supported when the used has included the format
+  data in the xport file via
+
+     PROC FORMAT CNTLOUT=format;
+
+  The write.xport function writes one or more data sets into a SAS xport
+  file.  Standard R data types, including date and time objects
+  (e.g. Date, and POSIX.t) are stored with proper SAS format types.
+  Handling of object formatting is customizable by providing methods for
+  the function toSAS().  This is accomplished by writing a new method
+  for toSAS() for the object class of interest. The toSAS() method is
+  responsible for converting its argument to either a simple floating
+  point or character variable (the only basic types permitted by the
+  xport format) and adding the appropriate SAS format code in the
+  'format' attribute. 
+
+  The write.xport() function, further, allows the user to override the
+  operating system type and SAS version information, as well as object
+  creation and modification times.
+
   
-Index:
+  This package was created by Random Technologies LLC
+  <http://random-technologies-llc.com> with funding by Metrum Institute
+  <http://metruminstitute.org>. 
+
+}
+\section{Index}{
 \preformatted{
 lookup.xport            Lookup Information on a SAS XPORT Format
                         Library
 read.xport              Import SAS XPORT files
-toSAS.default           Convert R data object for storage in SAS xport
-                        file
-units                   Set or Retreive the label, format, iformat, or
-                        units Attribute of a Vector
+toSAS.default           Convert R data object for storage in SAS 
+                        xport file
+units                   Set or Retreive the label, format, 
+                        iformat, or units Attribute of a Vector
 write.xport             Write data to a SAS XPORT file
 }
 }
 \author{
-Gregory R. Warnes <gr...@ra...>, includes
-code from Frank E. Harrell, Jr.'s Hmisc package.
+  Gregory R. Warnes <gr...@ra...>, includes
+  code from Frank E. Harrell, Jr.'s Hmisc package.
 
-Maintainer: Gregory R. Warnes <gr...@ra...>
+  Maintainer: Gregory R. Warnes <gr...@ra...>
 }
-\section{support}{
-Technical support contracts and other services for for R, this package,
-and other packages are available from Random Technologies LLC
-<http://random-technologies-llc.com>.
+\section{Support}{
+  Technical support contracts and other services for for R, this package,
+  and other packages are available from Random Technologies LLC
+  <http://random-technologies-llc.com>.
 }
 \keyword{ package }


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1132] trunk/SASxport/tests

From: <wa...@us...> - 2007-08-09 23:29:40

Revision: 1132
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1132&view=rev
Author:   warnes
Date:     2007-08-09 16:28:42 -0700 (Thu, 09 Aug 2007)

Log Message:
-----------
More changes, esp to lookup.xport() and friends

Modified Paths:
--------------
    trunk/SASxport/tests/Alfalfa_Test.Rout.save
    trunk/SASxport/tests/cars.Rout.save
    trunk/SASxport/tests/xport.Rout.save

Modified: trunk/SASxport/tests/Alfalfa_Test.Rout.save
===================================================================
--- trunk/SASxport/tests/Alfalfa_Test.Rout.save	2007-08-09 23:28:27 UTC (rev 1131)
+++ trunk/SASxport/tests/Alfalfa_Test.Rout.save	2007-08-09 23:28:42 UTC (rev 1132)
@@ -1,6 +1,6 @@
 
-R version 2.4.1 (2006-12-18)
-Copyright (C) 2006 The R Foundation for Statistical Computing
+R version 2.6.0 Under development (unstable) (2007-08-04 r42421)
+Copyright (C) 2007 The R Foundation for Statistical Computing
 ISBN 3-900051-07-0
 
 R is free software and comes with ABSOLUTELY NO WARRANTY.
@@ -15,17 +15,19 @@
 'help.start()' for an HTML browser interface to help.
 Type 'q()' to quit R.
 
-*******************************************************
-** This copy of RPro is licensed to:                 **
-** Gregory R. Warnes                                 **
-*******************************************************
-
-
-> invisible(options(echo = TRUE))
 > ## This test demonstrates that write.xport can exactly duplicate an
 > ## existing SAS xport file "Alfalfa.xpt"
 > 
 > library(SASxport)
+
+Attaching package: 'SASxport'
+
+
+	The following object(s) are masked from package:base :
+
+	 units,
+	 units<- 
+
 > 
 > # existing data file
 > SPEC <- read.xport("Alfalfa.xpt")
@@ -45,6 +47,3 @@
 > ## Test that the files are identical
 > SASxport:::assert( all(a.1 == a.2) )
 > 
-> proc.time()
-[1] 0.939 0.103 1.212 0.000 0.000
-> 

Modified: trunk/SASxport/tests/cars.Rout.save
===================================================================
--- trunk/SASxport/tests/cars.Rout.save	2007-08-09 23:28:27 UTC (rev 1131)
+++ trunk/SASxport/tests/cars.Rout.save	2007-08-09 23:28:42 UTC (rev 1132)
@@ -1,6 +1,6 @@
 
-R version 2.4.1 (2006-12-18)
-Copyright (C) 2006 The R Foundation for Statistical Computing
+R version 2.6.0 Under development (unstable) (2007-08-04 r42421)
+Copyright (C) 2007 The R Foundation for Statistical Computing
 ISBN 3-900051-07-0
 
 R is free software and comes with ABSOLUTELY NO WARRANTY.
@@ -15,16 +15,16 @@
 'help.start()' for an HTML browser interface to help.
 Type 'q()' to quit R.
 
-*******************************************************
-** This copy of RPro is licensed to:                 **
-** Gregory R. Warnes                                 **
-*******************************************************
+> library(SASxport)
 
+Attaching package: 'SASxport'
 
-[Previously saved workspace restored]
 
-> invisible(options(echo = TRUE))
-> library(SASxport)
+	The following object(s) are masked from package:base :
+
+	 units,
+	 units<- 
+
 > 
 > 
 > cars <- read.table(file="cars.sas", skip=3, nrows=26,
@@ -64,6 +64,3 @@
 > ## Test that the files are identical
 > SASxport:::assert( all(a.1 == a.2) )
 > 
-> proc.time()
-[1] 0.920 0.097 1.079 0.000 0.000
-> 

Modified: trunk/SASxport/tests/xport.Rout.save
===================================================================
--- trunk/SASxport/tests/xport.Rout.save	2007-08-09 23:28:27 UTC (rev 1131)
+++ trunk/SASxport/tests/xport.Rout.save	2007-08-09 23:28:42 UTC (rev 1132)
@@ -27,41 +27,20 @@
 
 > 
 > lookup.xport("Alfalfa.xpt")
-$SPEC
-$SPEC$headpad
-[1] 1360
 
-$SPEC$type
-[1] "character" "numeric"   "numeric"   "numeric"   "numeric"   "numeric"  
+SAS xport file
+--------------
+Filename: `Alfalfa.xpt'
 
-$SPEC$width
-[1] 8 8 8 8 8 8
+Variables in data set `SPEC':
+            dataset   name      type format width label nobs
+SPEC.POP       SPEC    POP character            8         40
+SPEC.SAMPLE    SPEC SAMPLE   numeric            8         40
+SPEC.REP       SPEC    REP   numeric            8         40
+SPEC.SEEDWT    SPEC SEEDWT   numeric            8         40
+SPEC.HARV1     SPEC  HARV1   numeric            8         40
+SPEC.HARV2     SPEC  HARV2   numeric            8         40
 
-$SPEC$index
-[1] 1 2 3 4 5 6
-
-$SPEC$position
-[1]  0  8 16 24 32 40
-
-$SPEC$name
-[1] "POP"    "SAMPLE" "REP"    "SEEDWT" "HARV1"  "HARV2" 
-
-$SPEC$label
-[1] "" "" "" "" "" ""
-
-$SPEC$format
-[1] "" "" "" "" "" ""
-
-$SPEC$sexptype
-[1] 16 14 14 14 14 14
-
-$SPEC$tailpad
-[1] 0
-
-$SPEC$length
-[1] 40
-
-
 > 
 > Alfalfa <- read.xport("Alfalfa.xpt")
 > 
@@ -84,41 +63,16 @@
 > ## test data provided by FR...@bi...
 > 
 > lookup.xport("test.xpt")
-$TEST
-$TEST$headpad
-[1] 800
 
-$TEST$type
-[1] "numeric" "numeric"
+SAS xport file
+--------------
+Filename: `test.xpt'
 
-$TEST$width
-[1] 8 8
+Variables in data set `TEST':
+       dataset name    type format width label nobs
+TEST.I    TEST    I numeric            8         12
+TEST.K    TEST    K numeric            8         12
 
-$TEST$index
-[1] 1 2
-
-$TEST$position
-[1] 0 8
-
-$TEST$name
-[1] "I" "K"
-
-$TEST$label
-[1] "" ""
-
-$TEST$format
-[1] "" ""
-
-$TEST$sexptype
-[1] 14 14
-
-$TEST$tailpad
-[1] 48
-
-$TEST$length
-[1] 12
-
-
 > testdata <- read.xport("test.xpt")
 > summary(testdata)
        i              k    


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1133] trunk/SASxport

From: <wa...@us...> - 2007-08-09 23:29:04

Revision: 1133
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1133&view=rev
Author:   warnes
Date:     2007-08-09 16:29:01 -0700 (Thu, 09 Aug 2007)

Log Message:
-----------
More changes, esp to lookup.xport() and friends

Modified Paths:
--------------
    trunk/SASxport/DESCRIPTION
    trunk/SASxport/NAMESPACE
    trunk/SASxport/man/lookup.xport.Rd
    trunk/SASxport/man/read.xport.Rd
    trunk/SASxport/man/units.Rd

Added Paths:
-----------
    trunk/SASxport/TODO

Modified: trunk/SASxport/DESCRIPTION
===================================================================
--- trunk/SASxport/DESCRIPTION	2007-08-09 23:28:42 UTC (rev 1132)
+++ trunk/SASxport/DESCRIPTION	2007-08-09 23:29:01 UTC (rev 1133)
@@ -3,11 +3,17 @@
 Title: Read and write SAS export files
 Version: 0.99.1
 Date: 2007-07-28
-Author: Gregory R. Warnes <gr...@ra...>
+Author: Gregory R. Warnes <gr...@ra...>,
+        includes code from Frank E. Harrell, Jr.'s Hmisc package.   
 Maintainer: Gregory R. Warnes <gr...@ra...>
 Description: This package provides functions to read, list contents of, and  
-             write SAS export files.  The creation of this package was funded
-             by Metrum Institute <http://metruminstitute.org>.
+             write SAS export files.  This package was created by Random 
+             Technologies LLC <http://random-technologies-llc.com> with funding
+             by Metrum Institute <http://metruminstitute.org>. 
+             .
+             Technical support contracts and other services for for R, this 
+             package, and other packages are available from Random Technologies
+             LLC <http://random-technologies-llc.com>.
 License: GPL 2.0 or later
 Imports: methods, foreign, chron
 

Modified: trunk/SASxport/NAMESPACE
===================================================================
--- trunk/SASxport/NAMESPACE	2007-08-09 23:28:42 UTC (rev 1132)
+++ trunk/SASxport/NAMESPACE	2007-08-09 23:29:01 UTC (rev 1133)
@@ -39,3 +39,7 @@
 S3method("formats<-", default)
 S3method("iformat<-", default)
 
+S3method(print, lookup.xport)
+S3method(summary, lookup.xport)
+S3method(print, summary.lookup.xport)
+

Added: trunk/SASxport/TODO
===================================================================
--- trunk/SASxport/TODO	                        (rev 0)
+++ trunk/SASxport/TODO	2007-08-09 23:29:01 UTC (rev 1133)
@@ -0,0 +1,17 @@
+- Write replacements for SAS's REVERSE function, which corrects for
+  differences in endianness, and cnxptieee function, which is used to
+  convert from the IBM floating point representation to the IEEE
+  representation.
+
+- Write test routines for very large files, particulary very large
+  files with columns contiaining almost all missing values.
+
+- Test that created files are properly read by SAS, particulary when
+  the SAS version and OS version are set to the default values I've
+  provided.
+
+- Check function for 64 bit versions of R.  I suspect that there may
+  be variable size issues for some int fields for write.xport().
+
+- 
+

Modified: trunk/SASxport/man/lookup.xport.Rd
===================================================================
--- trunk/SASxport/man/lookup.xport.Rd	2007-08-09 23:28:42 UTC (rev 1132)
+++ trunk/SASxport/man/lookup.xport.Rd	2007-08-09 23:29:01 UTC (rev 1133)
@@ -1,33 +1,75 @@
 \name{lookup.xport}
 \alias{lookup.xport}
+\alias{print.lookup.xport}
+\alias{summary.lookup.xport}
+\alias{print.summary.lookup.xport}
 \title{Lookup Information on a SAS XPORT Format Library}
 \description{
-  Scans a file as a SAS XPORT format library and returns a list
-  containing information about the SAS library.
+  Describe the contents of an SAS XPORT format file.
 }
 \usage{
 lookup.xport(file)
+\method{print}{lookup.xport}(x, ...)
+\method{summary}{lookup.xport}(x, ...)
+\method{print}{summary.lookup.xport}(x, ...)
 }
 \arguments{
-  \item{file}{character variable with the name of the file to read.  The
-    file must be in SAS XPORT format.}
+  \item{file}{Character string specifying the name or URL of a SAS XPORT file.}
+  \item{x}{Object to be printed or summarized}
+  \item{...}{Optional arguments}
 }
 \value{
-  A list with one component for each dataset in the XPORT format library.
+  \code{lookup.xport} returs a list with one component for each dataset
+  in the XPORT format library.
+
+  \code{summary.lookup.xport} returns a
+  single data frame containing the following component 
+  \item{dataset}{ Dataset name,}
+  \item{name}{ Variable name,}
+  \item{type}{ Type of variable (one of 'character' or 'numeric'),}
+  \item{format}{ SAS format, }
+  \item{width}{ SAS format width, }
+  \item{label}{ Variable label, }
+  \item{nobs}{ Number of observations. }
+  
 }
-\references{
-  SAS Technical Support document TS-140:
-  \dQuote{The Record Layout of a Data Set in SAS Transport (XPORT) Format}
-  available as
-  \url{http://ftp.sas.com/techsup/download/technote/ts140.html}.
+\details{
+  The   \code{lookup.xport} function is a simple wrapper for the
+  \code{\link[foreign]{lookup.xport}} function  provided by the
+  \code{foreign} library.  The wrapped adds the ability to handle URL's,
+  and returns an object of class  \code{lookup.xport} for which
+  appropriate \code{print}, and \code{summary} functions are provide. 
 } 
-\author{Saikat DebRoy}
 \seealso{
-  \code{\link{read.xport}}
+  For complete documentation of \code{lookup.xport} see the manual page
+  for \code{\link[foreign]{lookup.xport}}.
 }
 \examples{
 \dontrun{
-lookup.xport("transport")
+## Get information on a local file
+lookup.xport("xxx.xpt")
 }
+
+## Or read a copy of test2.xpt available on the web:
+url <- 'http://biostat.mc.vanderbilt.edu/cgi-bin/viewvc.cgi/*checkout*/Hmisc/trunk/tests/test2.xpt'
+w <- lookup.xport(url)
+
+# display the infromation (calls 'print.lookup.xport')
+w
+
+# names of data sets
+names(w)
+
+# names of variables within data sets
+w$Z$name
+
+# use summary
+wS <- summary(w)
+wS # same display
+
+# variable names within all data sets
+wS$name 
+
 }
 \keyword{file}
+\keyword{manip}
\ No newline at end of file

Modified: trunk/SASxport/man/read.xport.Rd
===================================================================
--- trunk/SASxport/man/read.xport.Rd	2007-08-09 23:28:42 UTC (rev 1132)
+++ trunk/SASxport/man/read.xport.Rd	2007-08-09 23:29:01 UTC (rev 1133)
@@ -17,8 +17,8 @@
            )
 }
 \arguments{
-  \item{file}{name of a file containing the SAS transport file. May be a
-    URL beginning with \code{http://}. 
+  \item{file}{Character string specifying the name or URL of a SAS XPORT
+    file.
   }
   \item{force.integer}{Logical flag indicating whether integer-valued
     variables should be returned as integers (\code{TRUE}) or doubles

Modified: trunk/SASxport/man/units.Rd
===================================================================
--- trunk/SASxport/man/units.Rd	2007-08-09 23:28:42 UTC (rev 1132)
+++ trunk/SASxport/man/units.Rd	2007-08-09 23:29:01 UTC (rev 1133)
@@ -1,20 +1,28 @@
 \name{units}
+
 \alias{units}
-
 \alias{units.default}
-
 \alias{units<-}
+\alias{units<-.default}
 
 \alias{label}
+\alias{label.default}
 \alias{label<-}
+\alias{label<-.default}
 
 \alias{formats}
+\alias{formats.default}
 \alias{formats<-}
+\alias{formats<-.default}
 
 \alias{iformat}
+\alias{iformat.default}
 \alias{iformat<-}
+\alias{iformat<-.default}
+
+
 \title{
-Set or Retreive the Label, Format, iFormat, or Units Attribute of a Vector  
+Set or Retreive the label, format, iformat, or units Attribute of a Vector  
 }
 \description{
   Sets or retrieves the \code{"label"}, \code{"format"},
@@ -24,41 +32,68 @@
   available in Frank Harrell's \code{Hmisc} package.
 }
 \usage{
-units(x, ...)
-\method{units}{default}(x, none='', \dots)
+units(x, default)
 units(x) <- value
+
+label(x, default)
+label(x) <- value
+
+formats(x, default)
+formats(x) <- value
+
+iformat(x, default)
+iformat(x) <- value
+
 }
 \arguments{
 \item{x}{any object}
-\item{\dots}{ignored}
-\item{value}{the units of the object, or ""}
-\item{none}{value to which to set result if no appropriate attribute is
-  found}
+\item{value}{new value for the  \code{"label"}, \code{"format"},
+  \code{"iformat"}, or \code{"units"} attribute of an object.}
+\item{default}{value to return when no appropriate attribute is
+  found.  The usual return value is NULL.}
 }
 \value{
-the units attribute of x, if any; otherwise, the \code{units} attribute of
-the \code{tspar} attribute of \code{x} if any; otherwise the value \code{none}
+  the contents of the \code{"label"}, \code{"format"}, \code{"iformat"}, or
+  \code{"units"} attribute of x, if any; otherwise, the value provided by
+  \code{default}.    
 }
 \author{Gregory R. Warnes \email{gr...@ra...} based
   on code from the \code{Hmisc} library by Frank E. Harrell, Jr.}
 \seealso{\code{\link{label}}}
 \examples{
+
 fail.time <- c(10,20)
-units(fail.time) <- "Day"
+
+# set attributes
+units(fail.time) <- 'Day'
 label(fail.time) <- 'Failure Time'
-fail.time
+formats(fail.time) <- 'Numeric2'
+iformat(fail.time) <- 'Numeric2'
+
+# display individual attributes
+units(fail.time)
+label(fail.time)
+formats(fail.time)
+iformat(fail.time)
+
+# display all attributes
+attributes(fail.time)
+
+# Example showing specification of default return value
+a <- 70
+label(a, default="no label")
+
+
 \dontrun{
-
 # for a nice display
 library(Hmisc)
 describe(fail.time)
 
-
-
 f <- cph(Surv(fail.time, event) ~ xx)
 plot(xx,xx2,xlab=paste(label(xx),", ",units(xx),"s",sep=""))
 }
+
 }
 \keyword{utilities}
 \keyword{interface}
-% Converted by Sd2Rd version 1.21.
+


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1131] trunk/SASxport/R

From: <wa...@us...> - 2007-08-09 23:28:30

Revision: 1131
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1131&view=rev
Author:   warnes
Date:     2007-08-09 16:28:27 -0700 (Thu, 09 Aug 2007)

Log Message:
-----------
More changes, esp to lookup.xport() and friends

Modified Paths:
--------------
    trunk/SASxport/R/AFirst.lib.s
    trunk/SASxport/R/lookup.xport.R
    trunk/SASxport/R/read.xport.R
    trunk/SASxport/R/write.xport.R

Added Paths:
-----------
    trunk/SASxport/R/all.is.numeric.R
    trunk/SASxport/R/in.opererator.R

Modified: trunk/SASxport/R/AFirst.lib.s
===================================================================
--- trunk/SASxport/R/AFirst.lib.s	2007-08-09 19:02:22 UTC (rev 1130)
+++ trunk/SASxport/R/AFirst.lib.s	2007-08-09 23:28:27 UTC (rev 1131)
@@ -17,3 +17,9 @@
   existsFunction <- function(...) exists(..., mode='function')
 }
 
+if(.R.) {  
+  ## create some function definitions just to avoid R CMD CHECK warnings
+  timeDate <- function(...) stop("Not Implemented")
+  dates <- function(...) stop("Not Implemented")
+}
+

Added: trunk/SASxport/R/all.is.numeric.R
===================================================================
--- trunk/SASxport/R/all.is.numeric.R	                        (rev 0)
+++ trunk/SASxport/R/all.is.numeric.R	2007-08-09 23:28:27 UTC (rev 1131)
@@ -0,0 +1,22 @@
+##
+## Code originally from Frank Harrell's 'Hmisc' library: 
+##   http://biostat.mc.vanderbilt.edu/twiki/bin/view/Main/Hmisc
+## Copied with permission on 2007-08-04
+##
+
+all.is.numeric <- function(x, what=c('test','vector'), extras=c('.','NA'))
+{
+  what <- match.arg(what)
+  old <- options(warn=-1)
+  on.exit(options(old))
+  ##.Options$warn <- -1  6Aug00
+  x <- sub('[[:space:]]+$', '', x)
+  x <- sub('^[[:space:]]+', '', x)
+  xs <- x[x %nin% c('',extras)]
+  isnum <- !any(is.na(as.numeric(xs)))
+  if(what=='test')
+    isnum
+  else if(isnum)
+    as.numeric(x)
+  else x
+}

Added: trunk/SASxport/R/in.opererator.R
===================================================================
--- trunk/SASxport/R/in.opererator.R	                        (rev 0)
+++ trunk/SASxport/R/in.opererator.R	2007-08-09 23:28:27 UTC (rev 1131)
@@ -0,0 +1,7 @@
+##
+## Code originally from Frank Harrell's 'Hmisc' library: 
+##   http://biostat.mc.vanderbilt.edu/twiki/bin/view/Main/Hmisc
+## Copied with permission on 2007-08-04
+##
+
+"%nin%" <- function(a, b) ! (a %in% b)

Modified: trunk/SASxport/R/lookup.xport.R
===================================================================
--- trunk/SASxport/R/lookup.xport.R	2007-08-09 19:02:22 UTC (rev 1130)
+++ trunk/SASxport/R/lookup.xport.R	2007-08-09 23:28:27 UTC (rev 1131)
@@ -1,2 +1,62 @@
 ## Simply make this accessible here as a convenience to the user
-lookup.xport <- foreign:::lookup.xport
+lookup.xport <- function(file)
+  {
+    fname <- file
+
+    if(length(grep('http://', file))>0 || length(grep('ftp://', file))>0 )
+      {
+        scat("Downloading file...")        
+        tf <- tempfile()
+        download.file(file, tf, mode='wb', quiet=TRUE)
+        file <- tf
+      }
+
+    ret <- foreign:::lookup.xport(file)
+    attr(ret, "call") <- match.call()
+    attr(ret, "file") <- fname
+    class(ret) <- c("lookup.xport", "list")
+    ret
+  }
+
+print.lookup.xport <- function(x, ...)
+  {
+    Sinfo <- summary(x, ...)
+    print(Sinfo)
+  }
+
+
+summary.lookup.xport <- function(object, ...)
+  {
+    subFun <- function(XX)
+      {
+        df <- object[[XX]]
+        ret <- as.data.frame(df[c("name","type","format","width","label")])
+        cbind(dataset=XX, ret, nobs=df$length)
+      }
+    
+    dFrames <- lapply( names(object), subFun )
+    singleFrame <- do.call("rbind", dFrames)
+    rownames(singleFrame) <- paste(singleFrame$dataset, singleFrame$name, sep=".")
+
+    attr(singleFrame, "call") <- attr(object, "call")
+    attr(singleFrame, "file") <- attr(object, "file")    
+    class(singleFrame) <- c("summary.lookup.xport","data.frame")
+    
+    singleFrame
+  }
+
+print.summary.lookup.xport <- function(x, ...)
+{
+  cat("\n")
+  cat("SAS xport file\n")
+  cat("--------------\n");
+  cat("Filename: `", attr(x,"file"), "'\n", sep="")
+  cat("\n")
+  for(dSetName in levels(x$dataset))
+    {
+      cat("Variables in data set `", dSetName, "':\n", sep="")
+      print(as.data.frame(x)[x$dataset==dSetName,], row.names=FALSE)
+      cat("\n")
+    }
+}
+

Modified: trunk/SASxport/R/read.xport.R
===================================================================
--- trunk/SASxport/R/read.xport.R	2007-08-09 19:02:22 UTC (rev 1130)
+++ trunk/SASxport/R/read.xport.R	2007-08-09 23:28:27 UTC (rev 1131)
@@ -21,12 +21,6 @@
     sastimeform     <- toupper(c("hhmm","hour","mmss","time"))
     sasdatetimeform <- toupper(c("datetime","tod"))
 
-    if(length(grep('http://', file))) {
-      tf <- tempfile()
-      download.file(file, tf, mode='wb', quiet=TRUE)
-      file <- tf
-    }
-
     if(verbose)
       {
         oldOptionsDebug <- options("DEBUG")
@@ -34,6 +28,14 @@
         on.exit(options(DEBUG=oldOptionsDebug))
       }
 
+    if(length(grep('http://', file))>0 || length(grep('ftp://', file))>0 )
+      {
+        scat("Downloading file...")        
+        tf <- tempfile()
+        download.file(file, tf, mode='wb', quiet=TRUE)
+        file <- tf
+      }
+
     scat("Extracting data file information...")
     dsinfo <- foreign:::lookup.xport(file)
 

Modified: trunk/SASxport/R/write.xport.R
===================================================================
--- trunk/SASxport/R/write.xport.R	2007-08-09 19:02:22 UTC (rev 1130)
+++ trunk/SASxport/R/write.xport.R	2007-08-09 23:28:27 UTC (rev 1131)
@@ -51,10 +51,10 @@
     scat("Done")
 
     if(file==stdout())
-      out <- function(what)
+      out <- function(...)
         {
-          cat("ASCII: ", rawToDisplay(what), "")
-          cat("HEX:   ", what, "")
+          cat("ASCII: ", rawToDisplay(...), "")
+          cat("HEX:   ", ..., "")
         }
     else
       out <- function(...) writeBin( ..., raw(), con=file)


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1130] trunk/SASxport/src/swap_bytes.h

From: <wa...@us...> - 2007-08-09 19:02:24

Revision: 1130
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1130&view=rev
Author:   warnes
Date:     2007-08-09 12:02:22 -0700 (Thu, 09 Aug 2007)

Log Message:
-----------
Remove unused swap_bytes.h

Removed Paths:
-------------
    trunk/SASxport/src/swap_bytes.h

Deleted: trunk/SASxport/src/swap_bytes.h
===================================================================
--- trunk/SASxport/src/swap_bytes.h	2007-08-09 19:02:00 UTC (rev 1129)
+++ trunk/SASxport/src/swap_bytes.h	2007-08-09 19:02:22 UTC (rev 1130)
@@ -1,173 +0,0 @@
-/*
- *
- *  Reverse bytes in 2, 4 and 8 byte objects
- *
- *  Copyright 2000-2000 Saikat DebRoy <sa...@st...>
- *
- *  This program is free software; you can redistribute it and/or modify
- *  it under the terms of the GNU General Public License as published by
- *  the Free Software Foundation; either version 2 of the License, or
- *  (at your option) any later version.
- *
- *  This program is distributed in the hope that it will be
- *  useful, but WITHOUT ANY WARRANTY; without even the implied
- *  warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
- *  PURPOSE.  See the GNU General Public License for more
- *  details.
- *
- *  You should have received a copy of the GNU General Public
- *  License along with this program; if not, write to the Free
- *  Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- *  Boston, MA 02110-1301  USA
- *
- */
-
-#ifndef SWAP_BYTES_H
-#define SWAP_BYTES_H
-
-#undef HAVE_GLIBC_BSWAP
-
-#ifdef HAVE_GLIBC_BSWAP  /* use gnu bswap macros */
-
-#include <byteswap.h>
-
-#define swap_bytes_16(from, to) do { (to) = bswap_16(from); } while (0)
-
-#define swap_bytes_32(from, to) do { (to) = bswap_32(from); } while (0)
-
-#if defined __GNUC__ && __GNUC__ >= 2
-
-#define swap_bytes_double(from, to)		\
-do {						\
-    union {					\
-	unsigned long long int u64;		\
-	double d;				\
-    } __from, __to;				\
-    __from.d = (from);				\
-    __to.u64 = bswap_64(__from.u64);		\
-    (to) = __to.d;				\
-} while (0)
-
-#else
-
-#define swap_bytes_double(from, to)		\
-do {						\
-    union {					\
-	unsigned int u32[2];			\
-	double d;				\
-    } __from, __to;				\
-    __from.d = (from);  			\
-    swap_bytes_32(__from.u32[1], __to.u32[0]);	\
-    swap_bytes_32(__from.u32[0], __to.u32[1]);	\
-    (to) = __to.d;				\
-} while (0)
-
-#endif
-
-#else /* use reasonable portable definitions */
-
-#define swap_bytes_16(from, to)						\
-do {									\
-    unsigned short __from16 = (from);					\
-    (to) = ((((__from16) >> 8) & 0xff) | (((__from16) & 0xff) << 8));	\
-} while (0)
-
-#define swap_bytes_32(from, to)			\
-do {						\
-    unsigned int __from32 = (from);		\
-    (to) = (((__from32 & 0xff000000) >> 24) |	\
-	    ((__from32 & 0x00ff0000) >>  8) |	\
-	    ((__from32 & 0x0000ff00) <<  8) |	\
-	    ((__from32 & 0x000000ff) << 24));	\
-} while (0)
-
-#define swap_bytes_double(from, to)		\
-do {						\
-    union {					\
-	unsigned int u32[2];			\
-	double d;				\
-    } __from, __to;				\
-    __from.d = (from);  			\
-    swap_bytes_32(__from.u32[1], __to.u32[0]);	\
-    swap_bytes_32(__from.u32[0], __to.u32[1]);	\
-    (to) = __to.d;				\
-} while (0)
-#endif  /* HAVE_GLIBC_BSWAP */
-
-#define swap_bytes_ushort(from, to) swap_bytes_16(from, to)
-
-#define reverse_ushort(x) swap_bytes_16(x, x)
-
-#define swap_bytes_short(from, to)              \
-do {						\
-    union {					\
-	unsigned short u16;			\
-	short          s16;			\
-    } __from, __to;				\
-    __from.s16 = (from);			\
-    swap_bytes_16(__from.u16, __to.u16);	\
-    (to) = __to.s16;				\
-} while (0)
-
-#define reverse_short(x)                        \
-do {						\
-    union {					\
-	unsigned short u16;			\
-	short          s16;			\
-    } __from, __to;				\
-    __from.s16 = (x);    			\
-    swap_bytes_16(__from.u16, __to.u16);	\
-    (x) = __to.s16;				\
-} while(0)
-
-#define swap_bytes_uint(from, to) swap_bytes_32(from, to)
-
-#define reverse_uint(x) swap_bytes_32(x, x)
-
-#define swap_bytes_int(from, to)                \
-do {						\
-    union {					\
-	unsigned int u32;			\
-	int          s32;			\
-    } __from, __to;				\
-    __from.s32 = (from);			\
-    swap_bytes_32(__from.u32, __to.u32);	\
-    (to) = __to.s32;				\
-} while(0)
-
-#define reverse_int(x)                          \
-do {						\
-    union {					\
-	unsigned int u32;			\
-	int          s32;			\
-    } __from, __to;				\
-    __from.s32 = (x);    			\
-    swap_bytes_32(__from.u32, __to.u32);	\
-    (x) = __to.s32;				\
-} while(0)
-
-#define swap_bytes_float(from, to)		\
-do {						\
-    union {					\
-	unsigned int u32;			\
-	float f;				\
-    } __from, __to;				\
-    __from.f = (from);				\
-    swap_bytes_32(__from.u32, __to.u32);	\
-    (to) = __to.f;				\
-} while(0)
-
-#define reverse_float(x)        		\
-do {						\
-    union {					\
-	unsigned int u32;			\
-	float f;				\
-    } __from, __to;				\
-    __from.f = (x);				\
-    swap_bytes_32(__from.u32, __to.u32);	\
-    (x) = __to.f;				\
-} while(0)
-
-#define reverse_double(x) swap_bytes_double(x, x)
-
-#endif /* SWAP_BYTES_H */


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1129] trunk/SASxport/man/SASxport-package.Rd

From: <wa...@us...> - 2007-08-09 19:02:03

Revision: 1129
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1129&view=rev
Author:   warnes
Date:     2007-08-09 12:02:00 -0700 (Thu, 09 Aug 2007)

Log Message:
-----------
Add package description page

Added Paths:
-----------
    trunk/SASxport/man/SASxport-package.Rd

Added: trunk/SASxport/man/SASxport-package.Rd
===================================================================
--- trunk/SASxport/man/SASxport-package.Rd	                        (rev 0)
+++ trunk/SASxport/man/SASxport-package.Rd	2007-08-09 19:02:00 UTC (rev 1129)
@@ -0,0 +1,41 @@
+\name{SASxport-package}
+\alias{SASxport-package}
+\alias{SASxport}
+\docType{package}
+\title{
+Read and write SAS export files
+}
+\description{
+This package provides functions to read, list contents of,
+and write SAS export files.
+}
+\details{
+
+This package was created by Random
+Technologies LLC <http://random-technologies-llc.com> with funding by
+Metrum Institute <http://metruminstitute.org>.
+  
+Index:
+\preformatted{
+lookup.xport            Lookup Information on a SAS XPORT Format
+                        Library
+read.xport              Import SAS XPORT files
+toSAS.default           Convert R data object for storage in SAS xport
+                        file
+units                   Set or Retreive the label, format, iformat, or
+                        units Attribute of a Vector
+write.xport             Write data to a SAS XPORT file
+}
+}
+\author{
+Gregory R. Warnes <gr...@ra...>, includes
+code from Frank E. Harrell, Jr.'s Hmisc package.
+
+Maintainer: Gregory R. Warnes <gr...@ra...>
+}
+\section{support}{
+Technical support contracts and other services for for R, this package,
+and other packages are available from Random Technologies LLC
+<http://random-technologies-llc.com>.
+}
+\keyword{ package }


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1128] trunk/SASxport/R

From: <wa...@us...> - 2007-08-09 16:54:19

Revision: 1128
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1128&view=rev
Author:   warnes
Date:     2007-08-09 09:54:16 -0700 (Thu, 09 Aug 2007)

Log Message:
-----------
Add comment header indicating the source of code from Hmisc

Modified Paths:
--------------
    trunk/SASxport/R/importConvertDateTime.R
    trunk/SASxport/R/makeNames.R
    trunk/SASxport/R/read.xport.R
    trunk/SASxport/R/testDateTime.R

Modified: trunk/SASxport/R/importConvertDateTime.R
===================================================================
--- trunk/SASxport/R/importConvertDateTime.R	2007-08-09 16:53:14 UTC (rev 1127)
+++ trunk/SASxport/R/importConvertDateTime.R	2007-08-09 16:54:16 UTC (rev 1128)
@@ -1,3 +1,9 @@
+##
+## Code originally from Frank Harrell's 'Hmisc' library: 
+##   http://biostat.mc.vanderbilt.edu/twiki/bin/view/Main/Hmisc
+## Copied with permission on 2007-08-04
+##
+
 importConvertDateTime <- 
   function(x, type=c('date','time','datetime'),
            input=c('sas','spss','dataload'), form)

Modified: trunk/SASxport/R/makeNames.R
===================================================================
--- trunk/SASxport/R/makeNames.R	2007-08-09 16:53:14 UTC (rev 1127)
+++ trunk/SASxport/R/makeNames.R	2007-08-09 16:54:16 UTC (rev 1128)
@@ -1,3 +1,9 @@
+##
+## Code originally from Frank Harrell's 'Hmisc' library: 
+##   http://biostat.mc.vanderbilt.edu/twiki/bin/view/Main/Hmisc
+## Copied with permission on 2007-08-04
+##
+
 makeNames <- function(names, unique=FALSE, allow=NULL)
 {
   ## Runs make.names with exceptions in vector allow

Modified: trunk/SASxport/R/read.xport.R
===================================================================
--- trunk/SASxport/R/read.xport.R	2007-08-09 16:53:14 UTC (rev 1127)
+++ trunk/SASxport/R/read.xport.R	2007-08-09 16:54:16 UTC (rev 1128)
@@ -1,3 +1,9 @@
+##
+## Code originally from Frank Harrell's 'Hmisc' library: 
+##   http://biostat.mc.vanderbilt.edu/twiki/bin/view/Main/Hmisc
+## Copied with permission on 2007-08-04
+##
+
 read.xport <- function(file,
                        force.integer=TRUE,
                        formats=NULL,

Modified: trunk/SASxport/R/testDateTime.R
===================================================================
--- trunk/SASxport/R/testDateTime.R	2007-08-09 16:53:14 UTC (rev 1127)
+++ trunk/SASxport/R/testDateTime.R	2007-08-09 16:54:16 UTC (rev 1128)
@@ -1,3 +1,8 @@
+##
+## Code originally from Frank Harrell's 'Hmisc' library: 
+##   http://biostat.mc.vanderbilt.edu/twiki/bin/view/Main/Hmisc
+## Copied with permission on 2007-08-04
+##
 
 ## Determine if variable is a date, time, or date/time variable in R
 ## or S-Plus.  The following 2 functions are used by describe.vector


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1127] trunk/SASxport/tests

From: <wa...@us...> - 2007-08-09 16:53:15

Revision: 1127
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1127&view=rev
Author:   warnes
Date:     2007-08-09 09:53:14 -0700 (Thu, 09 Aug 2007)

Log Message:
-----------
Update saved output of test scripts

Modified Paths:
--------------
    trunk/SASxport/tests/testDates.Rout.save
    trunk/SASxport/tests/test_fields.Rout.save
    trunk/SASxport/tests/xport.Rout.save
    trunk/SASxport/tests/xxx.Rout.save

Modified: trunk/SASxport/tests/testDates.Rout.save
===================================================================
--- trunk/SASxport/tests/testDates.Rout.save	2007-08-08 18:54:43 UTC (rev 1126)
+++ trunk/SASxport/tests/testDates.Rout.save	2007-08-09 16:53:14 UTC (rev 1127)
@@ -1,6 +1,6 @@
 
-R version 2.4.1 (2006-12-18)
-Copyright (C) 2006 The R Foundation for Statistical Computing
+R version 2.6.0 Under development (unstable) (2007-08-04 r42421)
+Copyright (C) 2007 The R Foundation for Statistical Computing
 ISBN 3-900051-07-0
 
 R is free software and comes with ABSOLUTELY NO WARRANTY.
@@ -15,16 +15,16 @@
 'help.start()' for an HTML browser interface to help.
 Type 'q()' to quit R.
 
-*******************************************************
-** This copy of RPro is licensed to:                 **
-** Gregory R. Warnes                                 **
-*******************************************************
+> library(SASxport)
 
+Attaching package: 'SASxport'
 
-[Previously saved workspace restored]
 
-> invisible(options(echo = TRUE))
-> library(SASxport)
+	The following object(s) are masked from package:base :
+
+	 units,
+	 units<- 
+
 > 
 > ## Create a small data set containing dates, times, and date-times
 > 
@@ -47,7 +47,7 @@
 5 5 e 1992-02-01 1992-02-01 16:56:26
 > 
 > write.xport( DATETIME=temp, filename="datetime.xpt")
-> temp2 <- read.xport(file="datetime.xpt")
+> temp2 <- read.xport(file="datetime.xpt", names.tolower=FALSE)
 > 
 > print(temp2)
   X Y      DATES   DATETIME
@@ -61,6 +61,3 @@
 > identical(temp, temp2)
 [1] FALSE
 > 
-> proc.time()
-[1] 0.889 0.099 0.999 0.000 0.000
-> 

Modified: trunk/SASxport/tests/test_fields.Rout.save
===================================================================
--- trunk/SASxport/tests/test_fields.Rout.save	2007-08-08 18:54:43 UTC (rev 1126)
+++ trunk/SASxport/tests/test_fields.Rout.save	2007-08-09 16:53:14 UTC (rev 1127)
@@ -1,6 +1,6 @@
 
-R version 2.4.1 (2006-12-18)
-Copyright (C) 2006 The R Foundation for Statistical Computing
+R version 2.6.0 Under development (unstable) (2007-08-04 r42421)
+Copyright (C) 2007 The R Foundation for Statistical Computing
 ISBN 3-900051-07-0
 
 R is free software and comes with ABSOLUTELY NO WARRANTY.
@@ -15,16 +15,16 @@
 'help.start()' for an HTML browser interface to help.
 Type 'q()' to quit R.
 
-*******************************************************
-** This copy of RPro is licensed to:                 **
-** Gregory R. Warnes                                 **
-*******************************************************
+> library(SASxport)
 
+Attaching package: 'SASxport'
 
-[Previously saved workspace restored]
 
-> invisible(options(echo = TRUE))
-> library(SASxport)
+	The following object(s) are masked from package:base :
+
+	 units,
+	 units<- 
+
 > 
 > ## Call C-level test routines
 > 
@@ -33,6 +33,3 @@
 > 
 > ## Successful completion means all SASxport:::assertions have been met
 > 
-> proc.time()
-[1] 0.843 0.093 0.925 0.000 0.000
-> 

Modified: trunk/SASxport/tests/xport.Rout.save
===================================================================
--- trunk/SASxport/tests/xport.Rout.save	2007-08-08 18:54:43 UTC (rev 1126)
+++ trunk/SASxport/tests/xport.Rout.save	2007-08-09 16:53:14 UTC (rev 1127)
@@ -1,6 +1,6 @@
 
-R version 2.4.1 (2006-12-18)
-Copyright (C) 2006 The R Foundation for Statistical Computing
+R version 2.6.0 Under development (unstable) (2007-08-04 r42421)
+Copyright (C) 2007 The R Foundation for Statistical Computing
 ISBN 3-900051-07-0
 
 R is free software and comes with ABSOLUTELY NO WARRANTY.
@@ -15,16 +15,17 @@
 'help.start()' for an HTML browser interface to help.
 Type 'q()' to quit R.
 
-*******************************************************
-** This copy of RPro is licensed to:                 **
-** Gregory R. Warnes                                 **
-*******************************************************
+> library(SASxport)
 
+Attaching package: 'SASxport'
 
-[Previously saved workspace restored]
 
-> invisible(options(echo = TRUE))
-> library(SASxport)
+	The following object(s) are masked from package:base :
+
+	 units,
+	 units<- 
+
+> 
 > lookup.xport("Alfalfa.xpt")
 $SPEC
 $SPEC$headpad
@@ -61,23 +62,27 @@
 [1] 40
 
 
+> 
 > Alfalfa <- read.xport("Alfalfa.xpt")
+> 
 > summary(Alfalfa)
-  POP         SAMPLE         REP           SEEDWT          HARV1      
+  pop         sample         rep           seedwt          harv1      
  MAX:20   Min.   :0.0   Min.   :1.00   Min.   :35.00   Min.   :120.6  
  min:20   1st Qu.:2.0   1st Qu.:1.75   1st Qu.:47.75   1st Qu.:148.3  
           Median :4.5   Median :2.50   Median :59.00   Median :165.8  
           Mean   :4.5   Mean   :2.50   Mean   :56.08   Mean   :163.0  
           3rd Qu.:7.0   3rd Qu.:3.25   3rd Qu.:62.25   3rd Qu.:176.4  
           Max.   :9.0   Max.   :4.00   Max.   :75.00   Max.   :193.4  
-     HARV2      
+     harv2      
  Min.   :129.1  
  1st Qu.:150.6  
  Median :163.2  
  Mean   :167.1  
  3rd Qu.:179.6  
  Max.   :235.3  
+> 
 > ## test data provided by FR...@bi...
+> 
 > lookup.xport("test.xpt")
 $TEST
 $TEST$headpad
@@ -116,11 +121,12 @@
 
 > testdata <- read.xport("test.xpt")
 > summary(testdata)
-       I              K    
+       i              k    
  Min.   :1.00   Min.   :1  
  1st Qu.:1.75   1st Qu.:1  
  Median :2.50   Median :2  
  Mean   :2.50   Mean   :2  
  3rd Qu.:3.25   3rd Qu.:3  
  Max.   :4.00   Max.   :3  
+> 
 > q()

Modified: trunk/SASxport/tests/xxx.Rout.save
===================================================================
--- trunk/SASxport/tests/xxx.Rout.save	2007-08-08 18:54:43 UTC (rev 1126)
+++ trunk/SASxport/tests/xxx.Rout.save	2007-08-09 16:53:14 UTC (rev 1127)
@@ -1,6 +1,6 @@
 
-R version 2.4.1 (2006-12-18)
-Copyright (C) 2006 The R Foundation for Statistical Computing
+R version 2.6.0 Under development (unstable) (2007-08-04 r42421)
+Copyright (C) 2007 The R Foundation for Statistical Computing
 ISBN 3-900051-07-0
 
 R is free software and comes with ABSOLUTELY NO WARRANTY.
@@ -15,16 +15,16 @@
 'help.start()' for an HTML browser interface to help.
 Type 'q()' to quit R.
 
-*******************************************************
-** This copy of RPro is licensed to:                 **
-** Gregory R. Warnes                                 **
-*******************************************************
+> library(SASxport)
 
+Attaching package: 'SASxport'
 
-[Previously saved workspace restored]
 
-> invisible(options(echo = TRUE))
-> library(SASxport)
+	The following object(s) are masked from package:base :
+
+	 units,
+	 units<- 
+
 > 
 > ## manually create a data set
 > abc <- data.frame( x=c(1, 2, NA, NA ), y=c('a', 'B', NA, '*' ) )
@@ -44,11 +44,10 @@
 +             )
 > 
 > # read the original SAS data file
-> abc.SAS <- read.xport("xxx.xpt")
+> abc.SAS <- read.xport("xxx.xpt", names.tolower=FALSE)
 > 
-> ## read.xport currently doesn't store the format and label attributes...
+> ## read.xport currently doesn't store the format attribute...
 > attr(abc.SAS$X, 'format') <- 'date7.'
-> attr(abc.SAS$Y, 'label')  <- 'character variable'
 > 
 > # create a SAS XPORT file from the SAS data
 > write.xport(abc=abc.SAS,
@@ -79,6 +78,3 @@
 > 
 > 
 > 
-> proc.time()
-[1] 0.873 0.096 1.027 0.000 0.000
-> 


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1126] trunk/SASxport

From: <wa...@us...> - 2007-08-08 18:54:55

Revision: 1126
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1126&view=rev
Author:   warnes
Date:     2007-08-08 11:54:43 -0700 (Wed, 08 Aug 2007)

Log Message:
-----------
Updates

Modified Paths:
--------------
    trunk/SASxport/DESCRIPTION
    trunk/SASxport/NAMESPACE

Modified: trunk/SASxport/DESCRIPTION
===================================================================
--- trunk/SASxport/DESCRIPTION	2007-08-08 18:54:23 UTC (rev 1125)
+++ trunk/SASxport/DESCRIPTION	2007-08-08 18:54:43 UTC (rev 1126)
@@ -9,5 +9,5 @@
              write SAS export files.  The creation of this package was funded
              by Metrum Institute <http://metruminstitute.org>.
 License: GPL 2.0 or later
-Imports: methods
+Imports: methods, foreign, chron
 

Modified: trunk/SASxport/NAMESPACE
===================================================================
--- trunk/SASxport/NAMESPACE	2007-08-08 18:54:23 UTC (rev 1125)
+++ trunk/SASxport/NAMESPACE	2007-08-08 18:54:43 UTC (rev 1126)
@@ -1,19 +1,41 @@
 useDynLib(SASxport, .registration=TRUE)
 
+importFrom(foreign, read.xport, lookup.xport)
+importFrom(chron, chron)
+
 export(
-       assert,
        toSAS,
        lookup.xport,
        read.xport,
-       write.xport
+       write.xport,
+       "label",
+       "label<-",
+       
+       "units",
+       "units<-",
+       
+       "formats",
+       "formats<-",
+       
+       "iformat",
+       "iformat<-"
        )
 
-S3method(toSAS,numeric)
-S3method(toSAS,logical)
-S3method(toSAS,character)
-S3method(toSAS,factor)
-S3method(toSAS,POSIXt)
-S3method(toSAS,Date)
-S3method(toSAS,default)
+S3method(toSAS, numeric)
+S3method(toSAS, logical)
+S3method(toSAS, character)
+S3method(toSAS, factor)
+S3method(toSAS, POSIXt)
+S3method(toSAS, Date)
+S3method(toSAS, default)
 
+S3method(label, default)
+S3method(units, default)
+S3method(formats, default)
+S3method(iformat, default)
 
+S3method("label<-", default)
+S3method("units<-", default)
+S3method("formats<-", default)
+S3method("iformat<-", default)
+


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1125] trunk/SASxport/tests

From: <wa...@us...> - 2007-08-08 18:54:27

Revision: 1125
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1125&view=rev
Author:   warnes
Date:     2007-08-08 11:54:23 -0700 (Wed, 08 Aug 2007)

Log Message:
-----------
Updates

Modified Paths:
--------------
    trunk/SASxport/tests/Alfalfa_Test.R
    trunk/SASxport/tests/Alfalfa_Test.Rout.save
    trunk/SASxport/tests/cars.R
    trunk/SASxport/tests/cars.Rout.save
    trunk/SASxport/tests/datetime.xpt
    trunk/SASxport/tests/testDates.R
    trunk/SASxport/tests/test_fields.R
    trunk/SASxport/tests/test_fields.Rout.save
    trunk/SASxport/tests/xport.R
    trunk/SASxport/tests/xxx.R
    trunk/SASxport/tests/xxx.Rout.save

Modified: trunk/SASxport/tests/Alfalfa_Test.R
===================================================================
--- trunk/SASxport/tests/Alfalfa_Test.R	2007-08-08 18:54:00 UTC (rev 1124)
+++ trunk/SASxport/tests/Alfalfa_Test.R	2007-08-08 18:54:23 UTC (rev 1125)
@@ -19,4 +19,4 @@
 a.2 <- readBin( con="Alfalfa2.xpt", what=raw(), n=3600 )
 
 ## Test that the files are identical
-assert( all(a.1 == a.2) )
+SASxport:::assert( all(a.1 == a.2) )

Modified: trunk/SASxport/tests/Alfalfa_Test.Rout.save
===================================================================
--- trunk/SASxport/tests/Alfalfa_Test.Rout.save	2007-08-08 18:54:00 UTC (rev 1124)
+++ trunk/SASxport/tests/Alfalfa_Test.Rout.save	2007-08-08 18:54:23 UTC (rev 1125)
@@ -43,7 +43,7 @@
 > a.2 <- readBin( con="Alfalfa2.xpt", what=raw(), n=3600 )
 > 
 > ## Test that the files are identical
-> assert( all(a.1 == a.2) )
+> SASxport:::assert( all(a.1 == a.2) )
 > 
 > proc.time()
 [1] 0.939 0.103 1.212 0.000 0.000

Modified: trunk/SASxport/tests/cars.R
===================================================================
--- trunk/SASxport/tests/cars.R	2007-08-08 18:54:00 UTC (rev 1124)
+++ trunk/SASxport/tests/cars.R	2007-08-08 18:54:23 UTC (rev 1125)
@@ -22,4 +22,4 @@
 a.2 <- readBin( con="cars2.xpt", what=raw(), n=1e5)
 
 ## Test that the files are identical
-assert( all(a.1 == a.2) )
+SASxport:::assert( all(a.1 == a.2) )

Modified: trunk/SASxport/tests/cars.Rout.save
===================================================================
--- trunk/SASxport/tests/cars.Rout.save	2007-08-08 18:54:00 UTC (rev 1124)
+++ trunk/SASxport/tests/cars.Rout.save	2007-08-08 18:54:23 UTC (rev 1125)
@@ -62,7 +62,7 @@
 > a.2 <- readBin( con="cars2.xpt", what=raw(), n=1e5)
 > 
 > ## Test that the files are identical
-> assert( all(a.1 == a.2) )
+> SASxport:::assert( all(a.1 == a.2) )
 > 
 > proc.time()
 [1] 0.920 0.097 1.079 0.000 0.000

Modified: trunk/SASxport/tests/datetime.xpt
===================================================================
(Binary files differ)

Modified: trunk/SASxport/tests/testDates.R
===================================================================
--- trunk/SASxport/tests/testDates.R	2007-08-08 18:54:00 UTC (rev 1124)
+++ trunk/SASxport/tests/testDates.R	2007-08-08 18:54:23 UTC (rev 1125)
@@ -15,7 +15,7 @@
 print(temp)
 
 write.xport( DATETIME=temp, filename="datetime.xpt")
-temp2 <- read.xport(file="datetime.xpt")
+temp2 <- read.xport(file="datetime.xpt", names.tolower=FALSE)
 
 print(temp2)
 

Modified: trunk/SASxport/tests/test_fields.R
===================================================================
--- trunk/SASxport/tests/test_fields.R	2007-08-08 18:54:00 UTC (rev 1124)
+++ trunk/SASxport/tests/test_fields.R	2007-08-08 18:54:23 UTC (rev 1125)
@@ -4,4 +4,4 @@
 
 .C("doTest",PACKAGE="SASxport")
 
-## Successful completion means all assertions have been met
+## Successful completion means all SASxport:::assertions have been met

Modified: trunk/SASxport/tests/test_fields.Rout.save
===================================================================
--- trunk/SASxport/tests/test_fields.Rout.save	2007-08-08 18:54:00 UTC (rev 1124)
+++ trunk/SASxport/tests/test_fields.Rout.save	2007-08-08 18:54:23 UTC (rev 1125)
@@ -31,7 +31,7 @@
 > .C("doTest",PACKAGE="SASxport")
 list()
 > 
-> ## Successful completion means all assertions have been met
+> ## Successful completion means all SASxport:::assertions have been met
 > 
 > proc.time()
 [1] 0.843 0.093 0.925 0.000 0.000

Modified: trunk/SASxport/tests/xport.R
===================================================================
--- trunk/SASxport/tests/xport.R	2007-08-08 18:54:00 UTC (rev 1124)
+++ trunk/SASxport/tests/xport.R	2007-08-08 18:54:23 UTC (rev 1125)
@@ -1,9 +1,15 @@
 library(SASxport)
+
 lookup.xport("Alfalfa.xpt")
+
 Alfalfa <- read.xport("Alfalfa.xpt")
+
 summary(Alfalfa)
+
 ## test data provided by FR...@bi...
+
 lookup.xport("test.xpt")
 testdata <- read.xport("test.xpt")
 summary(testdata)
+
 q()

Modified: trunk/SASxport/tests/xxx.R
===================================================================
--- trunk/SASxport/tests/xxx.R	2007-08-08 18:54:00 UTC (rev 1124)
+++ trunk/SASxport/tests/xxx.R	2007-08-08 18:54:23 UTC (rev 1125)
@@ -18,11 +18,10 @@
             )
 
 # read the original SAS data file
-abc.SAS <- read.xport("xxx.xpt")
+abc.SAS <- read.xport("xxx.xpt", names.tolower=FALSE)
 
-## read.xport currently doesn't store the format and label attributes...
+## read.xport currently doesn't store the format attribute...
 attr(abc.SAS$X, 'format') <- 'date7.'
-attr(abc.SAS$Y, 'label')  <- 'character variable'
 
 # create a SAS XPORT file from the SAS data
 write.xport(abc=abc.SAS,
@@ -48,7 +47,7 @@
 a.1[1089] <- as.raw("0x2e")
 
 ## Test that the files are otherwise identical
-assert( all(a.1 == a.2) )
-assert( all(a.1 == a.3) )
+SASxport:::assert( all(a.1 == a.2) )
+SASxport:::assert( all(a.1 == a.3) )
 
 

Modified: trunk/SASxport/tests/xxx.Rout.save
===================================================================
--- trunk/SASxport/tests/xxx.Rout.save	2007-08-08 18:54:00 UTC (rev 1124)
+++ trunk/SASxport/tests/xxx.Rout.save	2007-08-08 18:54:23 UTC (rev 1125)
@@ -74,8 +74,8 @@
 > a.1[1089] <- as.raw("0x2e")
 > 
 > ## Test that the files are otherwise identical
-> assert( all(a.1 == a.2) )
-> assert( all(a.1 == a.3) )
+> SASxport:::assert( all(a.1 == a.2) )
+> SASxport:::assert( all(a.1 == a.3) )
 > 
 > 
 > 


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1124] trunk/SASxport/src

From: <wa...@us...> - 2007-08-08 18:54:22

Revision: 1124
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1124&view=rev
Author:   warnes
Date:     2007-08-08 11:54:00 -0700 (Wed, 08 Aug 2007)

Log Message:
-----------
Updates

Modified Paths:
--------------
    trunk/SASxport/src/init.c

Removed Paths:
-------------
    trunk/SASxport/src/SASxport.c
    trunk/SASxport/src/SASxport.h
    trunk/SASxport/src/foreign.h

Deleted: trunk/SASxport/src/SASxport.c
===================================================================
--- trunk/SASxport/src/SASxport.c	2007-08-08 18:53:42 UTC (rev 1123)
+++ trunk/SASxport/src/SASxport.c	2007-08-08 18:54:00 UTC (rev 1124)
@@ -1,649 +0,0 @@
-/*
- *
- *  Read SAS transport data set format
- *
- *  Copyright 1999-1999 Douglas M. Bates <ba...@st...>,
- *                      Saikat DebRoy <sa...@st...>
- *
- *  This program is free software; you can redistribute it and/or modify
- *  it under the terms of the GNU General Public License as published by
- *  the Free Software Foundation; either version 2 of the License, or
- *  (at your option) any later version.
- *
- *  This program is distributed in the hope that it will be
- *  useful, but WITHOUT ANY WARRANTY; without even the implied
- *  warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
- *  PURPOSE.  See the GNU General Public License for more
- *  details.
- *
- *  You should have received a copy of the GNU General Public
- *  License along with this program; if not, write to the Free
- *  Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- *  Boston, MA 02110-1301  USA
- *
- */
-
-#include <stdio.h>
-#include <string.h>
-#include <R.h>
-#include <Rinternals.h>
-#include "foreign.h"
-#include "SASxport.h"
-
-#define HEADER_BEG "HEADER RECORD*******"
-#define HEADER_TYPE_LIBRARY "LIBRARY "
-#define HEADER_TYPE_MEMBER "MEMBER  "
-#define HEADER_TYPE_DSCRPTR "DSCRPTR "
-#define HEADER_TYPE_NAMESTR "NAMESTR "
-#define HEADER_TYPE_OBS "OBS     "
-#define HEADER_END "HEADER RECORD!!!!!!!000000000000000000000000000000  "
-
-#define LIB_HEADER HEADER_BEG HEADER_TYPE_LIBRARY HEADER_END
-#define MEM_HEADER HEADER_BEG HEADER_TYPE_MEMBER \
-                   "HEADER RECORD!!!!!!!000000000000000001600000000"
-#define DSC_HEADER HEADER_BEG HEADER_TYPE_DSCRPTR HEADER_END
-#define NAM_HEADER HEADER_BEG HEADER_TYPE_NAMESTR \
-                   "HEADER RECORD!!!!!!!000000"
-#define OBS_HEADER HEADER_BEG HEADER_TYPE_OBS HEADER_END
-#define BLANK24 "                        "
-
-#define GET_RECORD(rec, fp, len) \
-          fread((rec), sizeof(char), (size_t) (len), (fp))
-
-#define IS_SASNA_CHAR(c) ((c) == 0x5f || (c) == 0x2e || \
-                          (0x41 <= (c) && (c) <= 0x5a))
-
-#ifndef NULL
-#define NULL ((void *) 0)
-#endif
-
-
-#define Two32 4294967296.0
-
-static double get_IBM_double(char* c, size_t len)
-{
-				/* Conversion from IBM 360 format to double */
-/*
- * IBM format:
- * 6       5                 0
- * 3       1                 0
- *
- * SEEEEEEEMMMM ......... MMMM
- *
- * Sign bit, 7 bit exponent, 56 bit fraction. Exponent is
- * excess 64. The fraction is multiplied by a power of 16 of
- * the actual exponent. Normalized floating point numbers are
- * represented with the radix point immediately to the left of
- * the high order hex fraction digit.
- */
-    unsigned int i, upper, lower;
-				/* exponent is expressed here as
-				   excess 70 (=64+6) to accomodate
-				   integer conversion of c[1] to c[4] */
-    char negative = c[0] & 0x80, exponent = (c[0] & 0x7f) - 70, buf[4];
-    double value; 
-    char ibuf[8];
-
-    if (len < 2 || len > 8) 
-      error(_("invalid field length in numeric variable"));
-
-    /* this effectively zero-pads c: */
-    memset(ibuf, 0, (size_t) 8);
-    memcpy(ibuf, c, len);
-    c = ibuf;
-    /* check for missing value */
-    /* This isn't really right: NAs are ' ',  '.', A-Z plus zero fill */
-    if (c[1] == '\0' && c[0] != '\0') return R_NaReal;
-    /* convert c[1] to c[3] to an int */
-    buf[0] = '\0';
-    for (i = 1; i < 4; i++) buf[i] = c[i];
-    char_to_uint(buf, upper);
-    /* convert c[4] to c[7] to an int */
-    for (i = 0; i < 4; i++) buf[i] = c[i + 4];
-    char_to_uint(buf, lower);
-    /* initialize the constant if needed */
-    value = ((double) upper + ((double) lower)/Two32) *
-	pow(16., (double) exponent);
-    if (negative) value = -value;
-    return value;
-}
-
-static int
-get_nam_header(FILE *fp, struct SAS_XPORT_namestr *namestr, int length)
-{
-    char record[141];
-    int n;
-
-    record[length] = '\0';
-    n = GET_RECORD(record, fp, length);
-    if(n != length)
-	return 0;
-
-    char_to_short(record, namestr->ntype);
-    char_to_short(record+2, namestr->nhfun);
-    char_to_short(record+4, namestr->nlng);
-    char_to_short(record+6, namestr->nvar0);
-    memcpy(namestr->nname, record + 8, 8);
-    memcpy(namestr->nlabel, record + 16, 40);
-    memcpy(namestr->nform, record + 56, 8);
-    char_to_short(record+64, namestr->nfl);
-    char_to_short(record+66, namestr->nfd);
-    char_to_short(record+68, namestr->nfj);
-    memcpy(namestr->nfill, record + 70, 2);
-    memcpy(namestr->niform, record + 72, 8);
-    char_to_short(record+80, namestr->nifl);
-    char_to_short(record+82, namestr->nifd);
-    char_to_int(record+84, namestr->npos);
-    return 1;
-}
-
-static int
-get_lib_header(FILE *fp, struct SAS_XPORT_header *head)
-{
-    char record[81];
-    int n;
-
-    n = GET_RECORD(record, fp, 80);
-    if(n == 80 && strncmp(LIB_HEADER, record, 80) != 0)
-	error(_("file not in SAS transfer format"));
-  
-    n = GET_RECORD(record, fp, 80);
-    if(n != 80)
-	return 0;
-    record[80] = '\0';
-    memcpy(head->sas_symbol[0], record, 8);
-    memcpy(head->sas_symbol[1], record+8, 8);
-    memcpy(head->saslib, record+16, 8);
-    memcpy(head->sasver, record+24, 8);
-    memcpy(head->sas_os, record+32, 8);
-    if((strrchr(record+40, ' ') - record) != 63)
-	return 0;
-    memcpy(head->sas_create, record+64, 16);
-
-    n = GET_RECORD(record, fp, 80);
-    if(n != 80)
-	return 0;
-    record[80] = '\0';
-    memcpy(head->sas_mod, record, 16);
-    if((strrchr(record+16, ' ') - record) != 79)
-	return 0;
-    return 1;
-}
-  
-static int
-get_mem_header(FILE *fp, struct SAS_XPORT_member *member)
-{
-    char record[81];
-    int n;
-
-    n = GET_RECORD(record, fp, 80);
-    if(n != 80 || strncmp(DSC_HEADER, record, 80) != 0)
-	error(_("file not in SAS transfer format"));
-  
-    n = GET_RECORD(record, fp, 80);
-    if(n != 80)
-	return 0;
-    record[80] = '\0';
-    memcpy(member->sas_symbol, record, 8);
-    memcpy(member->sas_dsname, record+8, 8);
-    memcpy(member->sasdata, record+16, 8);
-    memcpy(member->sasver, record+24, 8);
-    memcpy(member->sas_osname, record+32, 8);
-    if((strrchr(record+40, ' ') - record) != 63)
-	return 0;
-    memcpy(member->sas_create, record+64, 16);
-
-    n = GET_RECORD(record, fp, 80);
-    if(n != 80)
-	return 0;
-    memcpy(member->sas_mod, record, 16);
-    if((strrchr(record+16, ' ') - record) != 79)
-	return 0;
-    return 1;
-}
-
-static int
-init_xport_info(FILE *fp)
-{
-    char record[81];
-    int n;
-    int namestr_length;
-
-    struct SAS_XPORT_header *lib_head;
-
-    lib_head = Calloc(1, struct SAS_XPORT_header);
-
-    if(!get_lib_header(fp, lib_head)) {
-	Free(lib_head);
-	error(_("SAS transfer file has incorrect library header"));
-    }
-
-    Free(lib_head);
-
-    n = GET_RECORD(record, fp, 80);
-    if(n != 80 || strncmp(MEM_HEADER, record, 75) != 0 ||
-       strncmp("  ", record+78, 2) != 0)
-	error(_("file not in SAS transfer format"));
-    record[78] = '\0';
-    sscanf(record+75, "%d", &namestr_length);
-
-    return namestr_length;
-}
-
-static int
-init_mem_info(FILE *fp, char *name)
-{
-    int length, n;
-    char record[81];
-    char *tmp;
-    struct SAS_XPORT_member  *mem_head;
-
-    mem_head = Calloc(1, struct SAS_XPORT_member);
-    if(!get_mem_header(fp, mem_head)) {
-	Free(mem_head);
-	error(_("SAS transfer file has incorrect member header"));
-    }
-
-    n = GET_RECORD(record, fp, 80);
-    record[80] = '\0';
-    if(n != 80 || strncmp(NAM_HEADER, record, 54) != 0 ||
-       (strrchr(record+58, ' ') - record) != 79) {
-	Free(mem_head);
-	error(_("file not in SAS transfer format"));
-    }
-    record[58] = '\0';
-    sscanf(record+54, "%d", &length);
-
-    tmp = strchr(mem_head->sas_dsname, ' ');
-    n = tmp - mem_head->sas_dsname;
-    if(n > 0) {
-	if (n > 8)
-	    n = 8;
-	strncpy(name, mem_head->sas_dsname, n);
-	name[n] = '\0';
-    } else name[0] = '\0';
-
-    Free(mem_head);
-
-    return length;
-}
-
-static int
-next_xport_info(FILE *fp, int namestr_length, int nvars, int *headpad,
-		int *tailpad, int *length, int *ntype, int *nlng,
-		int *nvar0, SEXP nname, SEXP nlabel, SEXP nform, int *npos)
-{
-    char *tmp;
-    char record[81];
-    int i, n, nbytes, totwidth, nlength, restOfCard;
-    struct SAS_XPORT_namestr *nam_head;
-
-    nam_head = Calloc(nvars, struct SAS_XPORT_namestr);
-
-    for(i = 0; i < nvars; i++) {
-	if(!get_nam_header(fp, nam_head+i, namestr_length)) {
-	    Free(nam_head);
-	    error(_("SAS transfer file has incorrect library header"));
-	}
-    }
-
-    *headpad = 480 + nvars * namestr_length;
-    i = *headpad % 80;
-    if(i > 0) {
-	i = 80 - i;
-	if (fseek(fp, i, SEEK_CUR) != 0) {
-	    Free(nam_head);
-	    error(_("file not in SAS transfer format"));
-	}
-	(*headpad) += i;
-    }
-    
-    n = GET_RECORD(record, fp, 80);
-    if(n != 80 || strncmp(OBS_HEADER, record, 80) != 0) {
-	Free(nam_head);
-	error(_("file not in SAS transfer format"));
-    }
-  
-    for(i = 0; i < nvars; i++) {
-	int nname_len = 0, nlabel_len = 0, nform_len = 0;
-	char tmpname[41];
-
-	ntype[i] = (int) ((nam_head[i].ntype == 1) ? REALSXP : STRSXP);
-	nlng[i]  = nam_head[i].nlng;
-	nvar0[i] = nam_head[i].nvar0;
-	npos[i]  = nam_head[i].npos;
-
-	/* Variable name */
-	nname_len = 8;
-	while (nname_len && nam_head[i].nname[nname_len-1] == ' ')
-	    nname_len--;
-	strncpy(tmpname, nam_head[i].nname, nname_len);
-	tmpname[nname_len] = '\0';
-	SET_STRING_ELT(nname, i, mkChar(tmpname));
-
-	/* Variable label */
-	nlabel_len = 40;
-	while (nlabel_len && nam_head[i].nlabel[nlabel_len-1] == ' ')
-	    nlabel_len--;
-	strncpy(tmpname, nam_head[i].nlabel, nlabel_len);
-	tmpname[nlabel_len] = '\0';
-	SET_STRING_ELT(nlabel, i, mkChar(tmpname));
-
-	/* Variable format name */
-	nform_len = 8;
-	while (nform_len && nam_head[i].nform[nform_len-1] == ' ')
-	    nform_len--;
-	strncpy(tmpname, nam_head[i].nform, nform_len);
-	tmpname[nform_len] = '\0';
-	SET_STRING_ELT(nform, i, mkChar(tmpname));
-    }
-
-    Free(nam_head);
-
-    totwidth = 0;
-    for(i = 0; i < nvars; i++)
-	totwidth += nlng[i];
-
-    nbytes = 0;
-    nlength = 0;
-/*      tmp = (char *) R_alloc(totwidth+1, sizeof(char)); */
-    tmp = CHAR(PROTECT(allocVector(CHARSXP, (totwidth<=80?81:(totwidth+1)) * 
-				   sizeof(char))));
-    restOfCard = 0;
-    *tailpad = 0;
-    while(!feof(fp)) {
-	int allSpace = 1;
-	fpos_t currentPos;
-
-/*  	restOfCard = 80 - (ftell(fp) % 80); */
-	if (fgetpos(fp, &currentPos)) {
-	    error(_("problem accessing SAS XPORT file"));
-	}
-
-	n = GET_RECORD(tmp, fp, restOfCard);
-	if (n != restOfCard) {
-	    allSpace = 0;
-	} else {
-	    for (i = 0; i < restOfCard; i++) {
-		if (tmp[i] != ' ') {
-		    allSpace = 0;
-		    break;
-		}
-	    }
-	}
-	if (allSpace) {
-  	    n = GET_RECORD(record, fp, 80);
-	    if (n < 1) {
-		*tailpad = restOfCard;
-		break;
-	    }
-	    if(n == 80 && strncmp(MEM_HEADER, record, 75) == 0 &&
-	       strncmp("  ", record+78, 2) == 0) {
-		*tailpad = restOfCard;
-		record[78] = '\0';
-		sscanf(record+75, "%d", &namestr_length);
-		break;
-	    }
-	}
-	if (fsetpos(fp, &currentPos)) {
-	    error(_("problem accessing SAS XPORT file"));
-	}
-
-	n = GET_RECORD(tmp, fp, totwidth);
-	if (n != totwidth) {
-	    if (!feof(fp)) {
-		error(_("problem accessing SAS XPORT file"));
-	    }
-	    *tailpad = n;
-	    break;
-	}
-	restOfCard = (restOfCard >= totwidth)?
-	    (restOfCard - totwidth):
-	    (80 - (totwidth - restOfCard)%80);
-	nlength++;
-    }
-    *length = nlength;
-    UNPROTECT(1);
-
-    return (feof(fp)?-1:namestr_length);
-}
-
-/*
- * get the list element named str.
- */
-
-static SEXP
-getListElement(SEXP list, char *str) {
-    SEXP names;
-    SEXP elmt = (SEXP) NULL;
-    char *tempChar;
-    int i;
-
-    names = getAttrib(list, R_NamesSymbol);
-
-    for (i = 0; i < LENGTH(list); i++) {
-	tempChar = CHAR(STRING_ELT(names, i));
-	if( strcmp(tempChar,str) == 0) {
-	    elmt = VECTOR_ELT(list, i);
-	    break;
-	}
-    }
-    return elmt;
-}
-
-#define VAR_INFO_LENGTH 11
-
-const char *cVarInfoNames[] = {
-    "headpad",
-    "type",
-    "width",
-    "index",
-    "position",
-    "name",
-    "label",
-    "format",
-    "sexptype",
-    "tailpad",
-    "length"
-};
-
-#define XPORT_VAR_HEADPAD(varinfo)   VECTOR_ELT(varinfo, 0)
-#define XPORT_VAR_TYPE(varinfo)      VECTOR_ELT(varinfo, 1)
-#define XPORT_VAR_WIDTH(varinfo)     VECTOR_ELT(varinfo, 2)
-#define XPORT_VAR_INDEX(varinfo)     VECTOR_ELT(varinfo, 3)
-#define XPORT_VAR_POSITION(varinfo)  VECTOR_ELT(varinfo, 4)
-#define XPORT_VAR_NAME(varinfo)      VECTOR_ELT(varinfo, 5)
-#define XPORT_VAR_LABEL(varinfo)     VECTOR_ELT(varinfo, 6)
-#define XPORT_VAR_FORM(varinfo)      VECTOR_ELT(varinfo, 7)
-#define XPORT_VAR_SEXPTYPE(varinfo)  VECTOR_ELT(varinfo, 8)
-#define XPORT_VAR_TAILPAD(varinfo)   VECTOR_ELT(varinfo, 9)
-#define XPORT_VAR_LENGTH(varinfo)    VECTOR_ELT(varinfo, 10)
-
-#define SET_XPORT_VAR_HEADPAD(varinfo, val)   SET_VECTOR_ELT(varinfo, 0, val)
-#define SET_XPORT_VAR_TYPE(varinfo, val)      SET_VECTOR_ELT(varinfo, 1, val)
-#define SET_XPORT_VAR_WIDTH(varinfo, val)     SET_VECTOR_ELT(varinfo, 2, val)
-#define SET_XPORT_VAR_INDEX(varinfo, val)     SET_VECTOR_ELT(varinfo, 3, val)
-#define SET_XPORT_VAR_POSITION(varinfo, val)  SET_VECTOR_ELT(varinfo, 4, val)
-#define SET_XPORT_VAR_NAME(varinfo, val)      SET_VECTOR_ELT(varinfo, 5, val)
-#define SET_XPORT_VAR_LABEL(varinfo, val)     SET_VECTOR_ELT(varinfo, 6, val)
-#define SET_XPORT_VAR_FORM(varinfo, val)      SET_VECTOR_ELT(varinfo, 7, val)
-#define SET_XPORT_VAR_SEXPTYPE(varinfo, val)  SET_VECTOR_ELT(varinfo, 8, val)
-#define SET_XPORT_VAR_TAILPAD(varinfo, val)   SET_VECTOR_ELT(varinfo, 9, val)
-#define SET_XPORT_VAR_LENGTH(varinfo, val)    SET_VECTOR_ELT(varinfo, 10, val)
-
-SEXP
-xport_info(SEXP xportFile)
-{
-    FILE *fp;
-    int i, namestrLength, memLength, ansLength;
-    char dsname[9];
-    SEXP ans, ansNames, varInfoNames, varInfo;
-    SEXP char_numeric, char_character;
-
-    PROTECT(varInfoNames = allocVector(STRSXP, VAR_INFO_LENGTH));
-    for(i = 0; i < VAR_INFO_LENGTH; i++)
-	SET_STRING_ELT(varInfoNames, i, mkChar(cVarInfoNames[i]));
-
-    PROTECT(char_numeric   = mkChar("numeric"));
-    PROTECT(char_character = mkChar("character"));
-
-    if(!isValidString(xportFile))
-	error(_("first argument must be a file name"));
-    fp = fopen(R_ExpandFileName(CHAR(STRING_ELT(xportFile, 0))), "rb");
-    if (!fp)
-	error(_("unable to open file"));
-    namestrLength = init_xport_info(fp);
-
-    ansLength = 0;
-    PROTECT(ans = allocVector(VECSXP, 0));
-    PROTECT(ansNames = allocVector(STRSXP, 0));
-
-    while(namestrLength > 0 && (memLength = init_mem_info(fp, dsname)) > 0) {
-
-	PROTECT(varInfo = allocVector(VECSXP, VAR_INFO_LENGTH));
-	setAttrib(varInfo, R_NamesSymbol, varInfoNames);
-
-	SET_XPORT_VAR_TYPE(varInfo, allocVector(STRSXP, memLength));
-	SET_XPORT_VAR_WIDTH(varInfo, allocVector(INTSXP, memLength));
-	SET_XPORT_VAR_INDEX(varInfo, allocVector(INTSXP, memLength));
-	SET_XPORT_VAR_POSITION(varInfo, allocVector(INTSXP, memLength));
-	SET_XPORT_VAR_NAME(varInfo, allocVector(STRSXP, memLength));
-	SET_XPORT_VAR_LABEL(varInfo, allocVector(STRSXP, memLength));
-	SET_XPORT_VAR_FORM(varInfo, allocVector(STRSXP, memLength));
-	SET_XPORT_VAR_SEXPTYPE(varInfo, allocVector(INTSXP, memLength));
-	SET_XPORT_VAR_HEADPAD(varInfo, allocVector(INTSXP, 1));
-	SET_XPORT_VAR_TAILPAD(varInfo, allocVector(INTSXP, 1));
-	SET_XPORT_VAR_LENGTH(varInfo, allocVector(INTSXP, 1));
-
-	namestrLength =
-	    next_xport_info(fp, namestrLength, memLength,
-			    INTEGER(XPORT_VAR_HEADPAD(varInfo)),
-			    INTEGER(XPORT_VAR_TAILPAD(varInfo)),
-			    INTEGER(XPORT_VAR_LENGTH(varInfo)),
-			    INTEGER(XPORT_VAR_SEXPTYPE(varInfo)),
-			    INTEGER(XPORT_VAR_WIDTH(varInfo)),
-			    INTEGER(XPORT_VAR_INDEX(varInfo)),
-			    XPORT_VAR_NAME(varInfo),
-			    XPORT_VAR_LABEL(varInfo),
-			    XPORT_VAR_FORM(varInfo),
-			    INTEGER(XPORT_VAR_POSITION(varInfo)));
-
-	for(i = 0; i < memLength; i++) {
-	    int *ntype = INTEGER(XPORT_VAR_SEXPTYPE(varInfo));
-	    SET_STRING_ELT(XPORT_VAR_TYPE(varInfo), i,
-			   (ntype[i] == REALSXP) ? char_numeric :
-			   char_character);
-	}
-	PROTECT(ans = lengthgets(ans, ansLength+1));
-	PROTECT(ansNames = lengthgets(ansNames, ansLength+1));
-/*  	PROTECT(newAns = allocVector(VECSXP, ansLength+1)); */
-/*  	PROTECT(newAnsNames = allocVector(STRSXP, ansLength+1)); */
-
-/*  	for(i = 0; i < ansLength; i++) { */
-/*  	    SET_VECTOR_ELT(newAns, i, VECTOR_ELT(ans, i)); */
-/*  	    SET_STRING_ELT(newAnsNames, i, STRING_ELT(ansNames, i)); */
-/*  	} */
-/*  	ans = newAns; */
-/*  	ansNames = newAnsNames; */
-
-	SET_STRING_ELT(ansNames, ansLength, mkChar(dsname));
-	SET_VECTOR_ELT(ans, ansLength, varInfo);
-	ansLength++;
- 
-	UNPROTECT(5);
-	PROTECT(ans);
-	PROTECT(ansNames);
-    }
-
-    setAttrib(ans, R_NamesSymbol, ansNames);  
-    UNPROTECT(5);
-    fclose(fp);
-    return ans;
-}
-
-SEXP
-xport_read(SEXP xportFile, SEXP xportInfo)
-{
-    int i, j, k, n;
-    int nvar;
-    int ansLength, dataLength, totalWidth;
-    int dataHeadPad, dataTailPad;
-    int *dataWidth;
-    int *dataPosition;
-    SEXPTYPE *dataType;
-    char *record, *tmpchar, *c;
-    FILE *fp;
-    SEXP ans, names, data, dataInfo, dataName;
-
-    ansLength = LENGTH(xportInfo);
-    PROTECT(ans = allocVector(VECSXP, ansLength));
-    names = getAttrib(xportInfo, R_NamesSymbol);
-    setAttrib(ans, R_NamesSymbol, names);
-
-    if(!isValidString(xportFile))
-	error(_("first argument must be a file name"));
-    fp = fopen(R_ExpandFileName(CHAR(STRING_ELT(xportFile, 0))), "rb");
-    if (!fp)
-	error(_("unable to open file"));
-    if (fseek(fp, 240, SEEK_SET) != 0)
-	error(_("problem reading SAS XPORT file '%s'"),
-	      CHAR(STRING_ELT(xportFile, 0)));
-
-    for(i = 0; i < ansLength; i++) {
-	dataInfo = VECTOR_ELT(xportInfo, i);
-	dataName = getListElement(dataInfo, "name");
-	nvar = LENGTH(dataName);
-	dataLength = asInteger(getListElement(dataInfo, "length"));
-	SET_VECTOR_ELT(ans, i, data = allocVector(VECSXP, nvar));
-	setAttrib(data, R_NamesSymbol, dataName);
-	dataType = (SEXPTYPE *) INTEGER(getListElement(dataInfo, "sexptype"));
-	for(j = 0; j < nvar; j++)
-	    SET_VECTOR_ELT(data, j, allocVector(dataType[j], dataLength));
-
-	dataWidth = INTEGER(getListElement(dataInfo, "width"));
-	dataPosition = INTEGER(getListElement(dataInfo, "position"));
-
-	totalWidth = 0;
-	for(j = 0; j < nvar; j++)
-	    totalWidth += dataWidth[j];
-/* 	record = (char *) R_alloc(totalWidth + 1, sizeof (char)); */
-	record = CHAR(PROTECT(allocVector(CHARSXP,
-					  (totalWidth+1) * sizeof(char))));
-
-	dataHeadPad = asInteger(getListElement(dataInfo, "headpad"));
-	dataTailPad = asInteger(getListElement(dataInfo, "tailpad"));
-	fseek(fp, dataHeadPad, SEEK_CUR);
-
-	for(j = 0; j < dataLength; j++) {
-	    n = GET_RECORD(record, fp, totalWidth);
-	    if(n != totalWidth) {
-		error(_("problem reading SAS transport file"));
-	    }
-
-	    for(k = nvar-1; k >= 0; k--) {
-		tmpchar = record + dataPosition[k];
-		if(dataType[k] == REALSXP) {
-		    REAL(VECTOR_ELT(data, k))[j] = 
-			get_IBM_double(tmpchar, dataWidth[k]);
-		} else {
-		    tmpchar[dataWidth[k]] = '\0';
-		    /* strip trailing blanks */
-		    c = tmpchar + dataWidth[k];
-		    while (c-- > tmpchar && *c == ' ')
-			*c ='\0';
-
-		    SET_STRING_ELT(VECTOR_ELT(data, k), j,
-				   (c < tmpchar) ? R_BlankString :
-				   mkChar(tmpchar));
-		}
-	    }
-	}
-
-	fseek(fp, dataTailPad, SEEK_CUR);
-	
-	UNPROTECT(1);
-    }
-    UNPROTECT(1);
-    fclose(fp);
-    return ans;
-}

Deleted: trunk/SASxport/src/SASxport.h
===================================================================
--- trunk/SASxport/src/SASxport.h	2007-08-08 18:53:42 UTC (rev 1123)
+++ trunk/SASxport/src/SASxport.h	2007-08-08 18:54:00 UTC (rev 1124)
@@ -1,77 +0,0 @@
-/*
- *
- *  This file is derived from code in the SAS Technical Support
- *  document TS-140 "The Record Layout of a Data Set in SAS Transport
- *  (XPORT) Format" available as 
- *       http://ftp.sas.com/techsup/download/technote/ts140.html
- */
-
-#ifndef SASEXPORT_H
-#define SASEXPORT_H
-
-#include <string.h>		/* for memcpy and memset */
-#include "foreign.h"
-#include "swap_bytes.h"
-
-/* double cnxptiee(double from, int fromtype, int totype); */
-
-
-
-struct SAS_XPORT_header { 
-  char sas_symbol[2][8];	/* should be "SAS     " */
-  char saslib[8];		/* should be "SASLIB  " */
-  char sasver[8];
-  char sas_os[8];
-  char sas_create[16];
-  char sas_mod[16];
-};
-
-struct SAS_XPORT_member { 
-  char sas_symbol[8];
-  char sas_dsname[8];
-  char sasdata[8];
-  char sasver[8]; 
-  char sas_osname[8];
-  char sas_create[16];
-  char sas_mod[16];
-};
-
-struct SAS_XPORT_namestr {
-    short   ntype;              /* VARIABLE TYPE: 1=NUMERIC, 2=CHAR    */
-    short   nhfun;              /* HASH OF NNAME (always 0)            */
-    short   nlng;               /* LENGTH OF VARIABLE IN OBSERVATION   */
-    short   nvar0;              /* VARNUM                              */
-    char    nname[8];		/* NAME OF VARIABLE                    */
-    char    nlabel[40];		/* LABEL OF VARIABLE                   */
-    char    nform[8];		/* NAME OF FORMAT                      */
-    short   nfl;                /* FORMAT FIELD LENGTH OR 0            */
-    short   nfd;                /* FORMAT NUMBER OF DECIMALS           */
-    short   nfj;                /* 0=LEFT JUSTIFICATION, 1=RIGHT JUST  */
-    char    nfill[2];           /* (UNUSED, FOR ALIGNMENT AND FUTURE)  */
-    char    niform[8];		/* NAME OF INPUT FORMAT                */
-    short   nifl;               /* INFORMAT LENGTH ATTRIBUTE           */
-    short   nifd;               /* INFORMAT NUMBER OF DECIMALS         */
-    int     npos;               /* POSITION OF VALUE IN OBSERVATION    */
-    char    rest[52];           /* remaining fields are irrelevant     */
-};
-
-#ifdef WORDS_BIGENDIAN
-
-#define char_to_short(from, to) memcpy(&to, from, 2)
-#define char_to_int(from, to) memcpy(&to, from, 4)
-#define char_to_uint(from, to) memcpy(&to, from, 4)
-
-#else
-
-#define char_to_short(from, to)	memcpy(&to, from, 2); reverse_short(to);
-#define char_to_int(from, to) memcpy(&to, from, 4); reverse_int(to);
-#define char_to_uint(from, to) memcpy(&to, from, 4); reverse_uint(to);
-
-#endif /* WORDS_BIGENDIAN */
-
-
-SEXP xport_info(SEXP xportFile);
-SEXP xport_read(SEXP xportFile, SEXP xportInfo);
-
-
-#endif /* SASEXPORT_H */

Deleted: trunk/SASxport/src/foreign.h
===================================================================
--- trunk/SASxport/src/foreign.h	2007-08-08 18:53:42 UTC (rev 1123)
+++ trunk/SASxport/src/foreign.h	2007-08-08 18:54:00 UTC (rev 1124)
@@ -1,79 +0,0 @@
-/*
- *
- *  Common header file for the foreign package for R
- *
- *  Copyright 2000-2000 Saikat DebRoy <sa...@st...>
- *                      Douglas M. Bates <ba...@st...>,
- *
- *  This program is free software; you can redistribute it and/or modify
- *  it under the terms of the GNU General Public License as published by
- *  the Free Software Foundation; either version 2 of the License, or
- *  (at your option) any later version.
- *
- *  This program is distributed in the hope that it will be
- *  useful, but WITHOUT ANY WARRANTY; without even the implied
- *  warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
- *  PURPOSE.  See the GNU General Public License for more
- *  details.
- *
- *  You should have received a copy of the GNU General Public
- *  License along with this program; if not, write to the Free
- *  Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
- *  Boston, MA 02110-1301  USA
- *
- */
-
-#ifndef FOREIGN_H
-#define FOREIGN_H
-
-#include <R.h>
-#include <Rinternals.h>
-
-#ifdef ENABLE_NLS
-#include <libintl.h>
-#define _(String) dgettext ("foreign", String)
-#define gettext_noop(String) (String)
-#else
-#define _(String) (String)
-#define gettext_noop(String) (String)
-#endif
-
-#define CN_TYPE_BIG     1
-#define CN_TYPE_LITTLE  2 
-#define CN_TYPE_XPORT   3
-#define CN_TYPE_IEEEB   CN_TYPE_BIG
-#define CN_TYPE_IEEEL   CN_TYPE_LITTLE
-
-#define BIG 4321
-#define LITTLE 1234
-#define UNKNOWN 0000
-
-#ifdef WORDS_BIGENDIAN
-# define CN_TYPE_NATIVE CN_TYPE_IEEEB
-# define endian BIG
-#else
-# define CN_TYPE_NATIVE CN_TYPE_IEEEL
-# define endian LITTLE
-#endif /* not WORDS_BIGENDIAN */
-
-typedef int R_int32;
-/* typedef short int16; unused */
-
-typedef double R_flt64;
-/* typedef float flt32; unused */
-
-#define FPREP_IEEE754 754
-#define FPREP FPREP_IEEE754
-
-#ifdef max
-# undef max
-#endif
-#ifdef min
-# undef min
-#endif
-#define max(a,b) ((a) >= (b) ? (a) : (b))
-#define min(a,b) ((a) <= (b) ? (a) : (b))
-
-extern char* R_ExpandFileName(char*);
-
-#endif /* FOREIGN_H */

Modified: trunk/SASxport/src/init.c
===================================================================
--- trunk/SASxport/src/init.c	2007-08-08 18:53:42 UTC (rev 1123)
+++ trunk/SASxport/src/init.c	2007-08-08 18:54:00 UTC (rev 1124)
@@ -22,8 +22,8 @@
 #include <Rinternals.h>
 #include <R_ext/Rdynload.h>
 #include "writeSAS.h"
-#include "foreign.h"
-#include "SASxport.h"
+//#include "foreign.h"
+//#include "SASxport.h"
 
 #define ARGTYPE static R_NativePrimitiveArgType
 
@@ -54,8 +54,8 @@
 
 #define CALLDEF(name, n)  {#name, (DL_FUNC) &name, n}
 static const R_CallMethodDef CallEntries[] = {
-    CALLDEF(xport_info, 1),
-    CALLDEF(xport_read, 2),
+//    CALLDEF(xport_info, 1),
+//    CALLDEF(xport_read, 2),
     CALLDEF(getRawBuffer, 0),
     {NULL, NULL, 0}
 };


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1123] trunk/SASxport/R

From: <wa...@us...> - 2007-08-08 18:53:47

Revision: 1123
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1123&view=rev
Author:   warnes
Date:     2007-08-08 11:53:42 -0700 (Wed, 08 Aug 2007)

Log Message:
-----------
Updates

Added Paths:
-----------
    trunk/SASxport/R/AFirst.lib.s
    trunk/SASxport/R/formats.R
    trunk/SASxport/R/iformat.R
    trunk/SASxport/R/importConvertDateTime.R
    trunk/SASxport/R/label.R
    trunk/SASxport/R/lookup.xport.R
    trunk/SASxport/R/makeNames.R
    trunk/SASxport/R/read.xport.R
    trunk/SASxport/R/testDateTime.R
    trunk/SASxport/R/units.R

Removed Paths:
-------------
    trunk/SASxport/R/xport.R

Added: trunk/SASxport/R/AFirst.lib.s
===================================================================
--- trunk/SASxport/R/AFirst.lib.s	                        (rev 0)
+++ trunk/SASxport/R/AFirst.lib.s	2007-08-08 18:53:42 UTC (rev 1123)
@@ -0,0 +1,19 @@
+##
+## Code originally from Frank Harrell's 'Hmisc' library: 
+##   http://biostat.mc.vanderbilt.edu/twiki/bin/view/Main/Hmisc
+## Copied with permission on 2007-08-04
+##
+
+## $Id: AFirst.lib.s,v 1.6 2005/09/26 15:44:17 dupontct Exp $
+under.unix <- !(version$os=='Microsoft Windows' ||
+                version$os=='Win32' || version$os=='mingw32')
+
+.R.   <- TRUE
+.SV4. <- FALSE
+
+.noGenenerics <- TRUE  # faster loading as new methods not used
+
+if(!exists('existsFunction')) {
+  existsFunction <- function(...) exists(..., mode='function')
+}
+

Added: trunk/SASxport/R/formats.R
===================================================================
--- trunk/SASxport/R/formats.R	                        (rev 0)
+++ trunk/SASxport/R/formats.R	2007-08-08 18:53:42 UTC (rev 1123)
@@ -0,0 +1,20 @@
+formats <- function(x, default)
+  UseMethod("formats")
+
+formats.default <- function(x, default=NULL)
+{
+  lab <- attr(x,"format")
+  if(is.null(lab))
+    default
+  else
+  lab
+}
+
+"formats<-" <- function(x, value)
+  UseMethod("formats<-")
+
+"formats<-.default" <- function(x, value)
+{
+  attr(x,'format') <- value
+  x
+}

Added: trunk/SASxport/R/iformat.R
===================================================================
--- trunk/SASxport/R/iformat.R	                        (rev 0)
+++ trunk/SASxport/R/iformat.R	2007-08-08 18:53:42 UTC (rev 1123)
@@ -0,0 +1,20 @@
+iformat <- function(x, default)
+  UseMethod("iformat")
+
+iformat.default <- function(x, default=NULL)
+{
+  lab <- attr(x,"iformat")
+  if(is.null(lab))
+    default
+  else
+  lab
+}
+
+"iformat<-" <- function(x, value)
+  UseMethod("iformat<-")
+
+"iformat<-.default" <- function(x, value)
+{
+  attr(x,'iformat') <- value
+  x
+}

Added: trunk/SASxport/R/importConvertDateTime.R
===================================================================
--- trunk/SASxport/R/importConvertDateTime.R	                        (rev 0)
+++ trunk/SASxport/R/importConvertDateTime.R	2007-08-08 18:53:42 UTC (rev 1123)
@@ -0,0 +1,40 @@
+importConvertDateTime <- 
+  function(x, type=c('date','time','datetime'),
+           input=c('sas','spss','dataload'), form)
+{
+  type <- match.arg(type)
+  input <- match.arg(input)
+
+  if(input != 'sas' && type != 'date')
+    stop('only date variables are support for spss, dataload')
+		
+ if(.R.) {
+    adjdays <- c(sas=3653, spss=141428, dataload=135080)[input]
+    ## 1970-1-1 minus 1960-1-1, 1582-10-14, or 1600-3-1
+    if(input=='spss') x <- x/86400
+
+    switch(type,
+           date = structure(x - adjdays, class='Date'),
+           time = {
+             ## Don MacQueen 3Apr02
+             z <- structure(x, class=c('POSIXt','POSIXct'))
+             f <- format(z, tz='GMT')
+             z <- as.POSIXct(format(z, tz='GMT'), tz='')
+             structure(z, class=c('timePOSIXt','POSIXt','POSIXct'))
+           },
+           datetime = {
+             chron((x - adjdays*86400)/86400,
+                   out.format=c(dates='day mon year', times='h:m:s'))
+           }
+           )
+  } else if(.SV4.) 
+    switch(type,
+           date     = timeDate(julian=x, format=form),
+           time     = timeDate(ms=x*1000, format=form),
+           datetime = timeDate(julian=x/86400, format=form))
+  else
+    switch(type,
+           date = dates(x, out.format=form),
+           time = chron(x/86400, out.format=form),
+           datetime = chron(x/86400, out.format=form))
+}

Added: trunk/SASxport/R/label.R
===================================================================
--- trunk/SASxport/R/label.R	                        (rev 0)
+++ trunk/SASxport/R/label.R	2007-08-08 18:53:42 UTC (rev 1123)
@@ -0,0 +1,20 @@
+label <- function(x, default)
+  UseMethod("label")
+
+label.default <- function(x, default=NULL)
+{
+  lab <- attr(x,"label")
+  if(is.null(lab))
+    default
+  else
+  lab
+}
+
+"label<-" <- function(x, value)
+  UseMethod("label<-")
+
+"label<-.default" <- function(x, value)
+{
+  attr(x,'label') <- value
+  x
+}

Added: trunk/SASxport/R/lookup.xport.R
===================================================================
--- trunk/SASxport/R/lookup.xport.R	                        (rev 0)
+++ trunk/SASxport/R/lookup.xport.R	2007-08-08 18:53:42 UTC (rev 1123)
@@ -0,0 +1,2 @@
+## Simply make this accessible here as a convenience to the user
+lookup.xport <- foreign:::lookup.xport

Added: trunk/SASxport/R/makeNames.R
===================================================================
--- trunk/SASxport/R/makeNames.R	                        (rev 0)
+++ trunk/SASxport/R/makeNames.R	2007-08-08 18:53:42 UTC (rev 1123)
@@ -0,0 +1,12 @@
+makeNames <- function(names, unique=FALSE, allow=NULL)
+{
+  ## Runs make.names with exceptions in vector allow
+  ## By default, R 1.9 make.names is overridden to convert _ to . as
+  ## with S-Plus and previous versions of R.  Specify allow='_' otherwise.
+  if(!.R. & length(allow))
+    stop('does not apply for S-Plus')
+  n <- make.names(names, unique)
+  if(!length(allow))
+    n <- gsub('_', '.', n)
+  n
+}

Added: trunk/SASxport/R/read.xport.R
===================================================================
--- trunk/SASxport/R/read.xport.R	                        (rev 0)
+++ trunk/SASxport/R/read.xport.R	2007-08-08 18:53:42 UTC (rev 1123)
@@ -0,0 +1,214 @@
+read.xport <- function(file,
+                       force.integer=TRUE,
+                       formats=NULL,
+                       name.chars=NULL,
+                       names.tolower=TRUE,
+                       keep=NULL,
+                       drop=NULL,
+                       as.is=0.95, # Prevent factor conversion if 95% or more unique
+                       verbose=FALSE
+                       )
+  {
+    sasdateform <-
+      toupper(c("date","mmddyy","yymmdd","ddmmyy","yyq","monyy",
+                "julian","qtr","weekdate","weekdatx","weekday","month"))
+    sastimeform     <- toupper(c("hhmm","hour","mmss","time"))
+    sasdatetimeform <- toupper(c("datetime","tod"))
+
+    if(length(grep('http://', file))) {
+      tf <- tempfile()
+      download.file(file, tf, mode='wb', quiet=TRUE)
+      file <- tf
+    }
+
+    if(verbose)
+      {
+        oldOptionsDebug <- options("DEBUG")
+        options(DEBUG=TRUE)
+        on.exit(options(DEBUG=oldOptionsDebug))
+      }
+
+    scat("Extracting data file information...")
+    dsinfo <- foreign:::lookup.xport(file)
+
+    if(length(keep))
+      whichds <- toupper(keep)
+    else
+
+      whichds <- setdiff(names(dsinfo), c(toupper(drop),'_CONTENTS_','_contents_'))
+
+    scat("Reading the data file...")
+    ds <- foreign:::read.xport(file)
+
+    if( (length(keep)>0 || length(drop)>0) )
+      ds <- ds[whichds]
+
+    scat("Processing contents...")
+    ## PROC FORMAT CNTLOUT= dataset present?
+    fds <- NULL
+    if(!length(formats)) {
+      fds <- sapply(dsinfo, function(x)
+                    all(c('FMTNAME','START','END','MIN','MAX','FUZZ')
+                        %in% x$name))
+      fds <- names(fds)[fds]
+      if(length(fds) > 1) {
+        warning('transport file contains more than one PROC FORMAT CNTLOUT= dataset; using only the first')
+        fds <- fds[1]
+      }
+    }
+  
+    finfo <- NULL
+    if(length(formats) || length(fds)) {
+      if(length(formats))
+        finfo <- formats
+      else
+        finfo <- ds[[fds]]
+
+      ## Remove leading $ from char format names
+      ##  fmtname <- sub('^\\$','',as.character(finfo$FMTNAME))
+      fmtname <- as.character(finfo$FMTNAME)
+      finfo <- split(finfo[c('START','END','LABEL')], fmtname)
+      finfo <- lapply(finfo,
+                      function(f)
+                      {
+                        rb <- function(a)
+                        {  # remove leading + trailing blanks
+                          a <- sub('[[:space:]]+$', '', as.character(a))
+                          sub('^[[:space:]]+', '', a)
+                        }
+
+                        st <- rb(f$START)
+                        en <- rb(f$END)
+                        lab <- rb(f$LABEL)
+                        ##j <- is.na(st) | is.na(en)
+                        ##  st %in% c('','.','NA') | en %in% c('','.','NA')
+                        j <- is.na(st) | is.na(en) | st == '' | en == ''
+                        if(any(j)) {
+                          warning('NA in code in FORMAT definition; removed')
+                          st <- st[!j]; en <- en[!j]; lab <- lab[!j]
+                        }
+
+                        if(!all(st==en))
+                          return(NULL)
+
+                        list(value = all.is.numeric(st, 'vector'),
+                             label = lab)
+                      })
+    }
+
+    ## Number of non-format datasets
+    nods <- length(whichds)
+    nds  <- nods - (length(formats) == 0 && length(finfo) > 0)
+    which.regular <- setdiff(whichds, fds)
+    dsn <- tolower(which.regular)
+
+
+    ## Handle lowercase name conversions
+    if(names.tolower)
+      names.tolower <- tolower
+    else
+      names.tolower <- function(x) x
+    
+    if(nds > 1)
+      {
+        res <- vector('list', nds)
+        names(res) <- gsub('_','.',dsn)
+      }
+
+    possiblyConvertChar <- (is.logical(as.is) && !as.is) ||
+    (is.numeric(as.is) && as.is > 0)
+    j <- 0
+    for(k in which.regular) {
+      j   <- j + 1
+      scat('Processing SAS dataset', k)
+      w   <-
+        if(nods==1)
+          ds
+        else ds[[k]]
+
+      scat('.')
+      
+      if(!length(w)) {
+        scat('Empty dataset', k, 'ignored\n')
+        next
+      }
+
+      nam      <- names.tolower(makeNames(names(w), allow=name.chars))
+      names(w) <- nam
+      dinfo    <- dsinfo[[k]]
+      fmt      <- sub('^\\$','',dinfo$format)
+      lab      <- dinfo$label
+      ndinfo   <- names.tolower(makeNames(dinfo$name, allow=name.chars))
+      names(lab) <- names(fmt) <- ndinfo
+      for(i in 1:length(w)) {
+        changed <- FALSE
+        x  <- w[[i]]
+        fi <- fmt[nam[i]]; names(fi) <- NULL
+        if(fi != '' && length(finfo) && (fi %in% names(finfo))) {
+          f <- finfo[[fi]]
+          if(length(f)) {  ## may be NULL because had a range in format
+            x <- factor(x, f$value, f$label)
+            attr(x, 'format') <- fi
+            changed <- TRUE
+          }
+        }
+
+        if(is.numeric(x)) {
+          if(fi %in% sasdateform) {
+            x <- importConvertDateTime(x, 'date', 'sas')
+            changed <- TRUE
+          } else if(fi %in% sastimeform) {
+            x <- importConvertDateTime(x, 'time', 'sas')
+            changed <- TRUE
+          } else if(fi %in% sasdatetimeform) {
+            x <- importConvertDateTime(x, 'datetime', 'sas')
+            changed <- TRUE
+          } else if(force.integer) {
+            if(all(is.na(x))) {
+              storage.mode(x) <- 'integer'
+              changed <- TRUE
+            } else if(max(abs(x),na.rm=TRUE) <= (2^31-1) &&
+                      all(floor(x) == x, na.rm=TRUE)) {
+              storage.mode(x) <- 'integer'
+              changed <- TRUE
+            }
+          }
+        } else if(possiblyConvertChar && is.character(x)) {
+          if((is.logical(as.is) && !as.is) || 
+             (is.numeric(as.is) && length(unique(x)) < as.is*length(x))) {
+            x <- factor(x, exclude='')
+            changed <- TRUE
+          }
+        }
+
+        lz <- lab[nam[i]]
+        if(lz != '') {
+          names(lz) <- NULL
+          label(x)  <- lz
+          changed   <- TRUE
+        }
+
+        fmt <- fmt[nam[i]]; 
+        if( !is.null(fmt) && !is.na(fmt) && fmt > '') {
+          names(fmt) <- NULL
+          formats(x) <- fmt
+          changed <- TRUE
+        }
+        
+        if(changed)
+          w[[i]] <- x
+      }
+
+      scat('.')
+
+      if(nds>1)
+        res[[j]] <- w
+    }
+
+    scat("Done")
+    
+    
+    if(nds > 1)
+      res
+    else w
+  }

Added: trunk/SASxport/R/testDateTime.R
===================================================================
--- trunk/SASxport/R/testDateTime.R	                        (rev 0)
+++ trunk/SASxport/R/testDateTime.R	2007-08-08 18:53:42 UTC (rev 1123)
@@ -0,0 +1,36 @@
+
+## Determine if variable is a date, time, or date/time variable in R
+## or S-Plus.  The following 2 functions are used by describe.vector
+## timeUsed assumes is date/time combination variable and has no NAs
+testDateTime <- function(x, what=c('either','both','timeVaries'))
+{
+  what <- match.arg(what)
+  cl <- class(x)  # was oldClass 22jun03
+  if(!length(cl))
+    return(FALSE)
+
+  dc <- if(.R.)
+          c('Date', 'POSIXt','POSIXct','dates','times','chron')
+        else
+          c('timeDate','date','dates','times','chron')
+  
+  dtc <- if(.R.)
+           c('POSIXt','POSIXct','chron')
+         else
+           c('timeDate','chron')
+  
+  switch(what,
+         either = any(cl %in% dc),
+         both   = any(cl %in% dtc),
+         timeVaries = {
+           if('chron' %in% cl || 'Date' %in% cl || !.R.) { 
+             ## chron or S+ timeDate
+             y <- as.numeric(x)
+             length(unique(round(y - floor(y),13))) > 1
+           }
+           else if(.R.)
+             length(unique(format(x,'%H%M%S'))) > 1
+           else
+             FALSE
+         })
+}

Added: trunk/SASxport/R/units.R
===================================================================
--- trunk/SASxport/R/units.R	                        (rev 0)
+++ trunk/SASxport/R/units.R	2007-08-08 18:53:42 UTC (rev 1123)
@@ -0,0 +1,20 @@
+units <- function(x, default)
+  UseMethod("units")
+
+units.default <- function(x, default=NULL)
+{
+  lab <- attr(x,"units")
+  if(is.null(lab))
+    default
+  else
+  lab
+}
+
+"units<-" <- function(x, value)
+  UseMethod("units<-")
+
+"units<-.default" <- function(x, value)
+{
+  attr(x,'units') <- value
+  x
+}

Deleted: trunk/SASxport/R/xport.R
===================================================================
--- trunk/SASxport/R/xport.R	2007-08-08 18:53:04 UTC (rev 1122)
+++ trunk/SASxport/R/xport.R	2007-08-08 18:53:42 UTC (rev 1123)
@@ -1,31 +0,0 @@
-###
-###             Read SAS xport format libraries
-###
-### Copyright 1999-1999 Douglas M. Bates <bates$stat.wisc.edu>,
-###                     Saikat DebRoy <saikat$stat.wisc.edu>
-###
-### This file is part of the `foreign' library for R and related languages.
-### It is made available under the terms of the GNU General Public
-### License, version 2, or at your option, any later version,
-### incorporated herein by reference.
-### 
-### This program is distributed in the hope that it will be
-### useful, but WITHOUT ANY WARRANTY; without even the implied
-### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-### PURPOSE.  See the GNU General Public License for more
-### details.
-### 
-### You should have received a copy of the GNU General Public
-### License along with this program; if not, write to the Free
-### Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
-### MA 02110-1301, USA
-
-lookup.xport <- function(file) .Call(xport_info, file)
-
-
-read.xport <- function(file) {
-    data.info <- lookup.xport(file)
-    ans <- .Call(xport_read, file, data.info)
-    if (length(ans) == 1) as.data.frame(ans[[1]])
-    else lapply(ans, as.data.frame)
-}


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1122] trunk/SASxport/man

From: <wa...@us...> - 2007-08-08 18:53:12

Revision: 1122
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1122&view=rev
Author:   warnes
Date:     2007-08-08 11:53:04 -0700 (Wed, 08 Aug 2007)

Log Message:
-----------
Updates.

Modified Paths:
--------------
    trunk/SASxport/man/read.xport.Rd

Added Paths:
-----------
    trunk/SASxport/man/units.Rd

Removed Paths:
-------------
    trunk/SASxport/man/assert.Rd

Deleted: trunk/SASxport/man/assert.Rd
===================================================================
--- trunk/SASxport/man/assert.Rd	2007-08-08 13:52:47 UTC (rev 1121)
+++ trunk/SASxport/man/assert.Rd	2007-08-08 18:53:04 UTC (rev 1122)
@@ -1,42 +0,0 @@
-\name{assert}
-\alias{assert}
-\title{Generate an error if an expression is not true.}
-\description{
-  Generate an error if an expression is not true.
-}
-\usage{
-assert(FLAG)
-}
-\arguments{
-  \item{FLAG}{ Expression that should evaluate to a boolean vector}
-}
-\details{
-  Assert generate an error if its aregument does not evaluate to 
-  boolean (vector) containing only \code{TRUE} values.  This is useful
-  for defensinve programming as it provides a mechanism for checking
-  that certain facts, the 'assertions', do in fact hold.  Checking of 
-  'assertions' is an important tool in the development of robust program
-  code.
-}
-\value{
-  None.  Evaluated only for its side effect.
-}
-\author{Gregory R. Warnes \email{wa...@bs...} }
-\seealso{ \code{\link[base]{stop}}, \code{\link[base]{warning}} }
-\examples{
-
-## Trivial example
-posSqrt <- function(x)
-  {
-    assert(x>=0)
-    sqrt(x)
-  }
-
-posSqrt(1:10) # works fine, no messages
-\dontrun{
-posSqrt(-5:5) # generates an error, since the asssertion is not met
-}
-
-
-}
-\keyword{programming}

Modified: trunk/SASxport/man/read.xport.Rd
===================================================================
--- trunk/SASxport/man/read.xport.Rd	2007-08-08 13:52:47 UTC (rev 1121)
+++ trunk/SASxport/man/read.xport.Rd	2007-08-08 18:53:04 UTC (rev 1122)
@@ -1,43 +1,190 @@
 \name{read.xport}
 \alias{read.xport}
-\title{Read a SAS XPORT Format Library}
+\title{Import SAS XPORT files}
 \description{
-  Reads a file as a SAS XPORT format library and returns a list of
-  data.frames.
+  Read a SAS XPORT format file and return the contained dataset(s).
 }
 \usage{
-read.xport(file)
+read.xport(file,
+           force.integer=TRUE,
+           formats=NULL,
+           name.chars=NULL,
+           names.tolower=TRUE,
+           keep=NULL,
+           drop=NULL,
+           as.is=0.95,
+           verbose=FALSE
+           )
 }
 \arguments{
- \item{file}{character variable with the name of the file to read.  The
-   file must be in SAS XPORT format.}
+  \item{file}{name of a file containing the SAS transport file. May be a
+    URL beginning with \code{http://}. 
+  }
+  \item{force.integer}{Logical flag indicating whether integer-valued
+    variables should be returned as integers (\code{TRUE}) or doubles
+    (\code{FALSE}). Variables outside the supported integer range
+    (\code{.Machine$integer.max}) will always be converted to
+    doubles. 
+  }
+  \item{formats}{a data frame or list (like that created by
+    \code{foreign:::read.xport}) containing \code{PROC FORMAT}
+    output, if such output is not stored in the main transport
+    file.
+  }
+  \item{name.chars}{Vector of additional characters permissible in
+    variable names. By default, only the alpha and numeric
+    characters ([A-Za-z0-9]) and periods ('.') are permitted. All
+    other characters are converted into periods ('.').   
+  }
+  \item{names.tolower}{Logical indicating whether variable and dataset
+    names should be converted to lowercase (\code{TRUE}) or left
+    uppercase (\code{FALSE})
+  }
+  \item{keep}{a vector of names of SAS datasets to process.  This list
+    must include \code{PROC FORMAT} dataset if it is present for
+    datasets to use use any of its value label formats.
+  } 
+  \item{drop}{a vector of names of SAS datasets to ignore (original SAS
+    upper case names)
+  }
+  \item{as.is}{
+    Either a logical flag indicating whether SAS character variables should
+    be preserved as character objects (\code{TRUE}) or factor
+    objects (\code{FALSE}), or a fractional cutoff between 0 and 1.
+    
+    When a fractional cutoff is provided, character variables
+    containing a more than this fraction of unique values will be
+    stored as a character variables. This is done in order to
+    preserve space, since factors must store both the integer factor
+    codes and the character factor labels.
+  }
+  \item{verbose}{Logical indicating whether progress should be printed
+    during the data loading and conversion process.}
 }
 \value{
-  If there is a more than one dataset in the XPORT format library, a named
-  list of data frames, otherwise a data frame.  The columns of the data
-  frames will be either numeric (corresponding to numeric in SAS) or
-  factor (corresponding to character in SAS).  All SAS numeric missing
-  values (including special missing values represented by \code{._},
-  \code{.A} to \code{.Z} by SAS) are mapped to \R \code{NA}.
+  If there is more than one dataset in the transport file other than the
+  \code{PROC FORMAT} file, the result is a list of data frames
+  containing all the non-\code{PROC FORMAT} datasets.  Otherwise the
+  result a single data frame.
+}
 
-  Trailing blanks are removed from character columns before conversion to
-  a factor.  Some sources claim that character missing values in SAS are
-  represented by \code{' '} or \code{''}: these are not treated as \R
-  missing values.
+\details{
+
+  \itemize{
+    \item variable names are converted to lower case
+    
+    \item SAS date, time, and date/time variables are converted respectively to \code{Date}, 
+    POSIX, or \code{chron} objects
+    
+    \item SAS labels are stored in "label" attributes on each variables
+    
+    \item SAS formats are stored in "format" attributes on each variable
+    
+    \item SAS integer variables are stored as integers unless
+      \code{force.integer} is \code{FALSE}
+  }
+
+  If the file incoudes the output of \code{PROC FORMAT CNTLOUT=},
+  variables having customized label formats will be converted to \code{factor}
+  objects with appropriate labels.
 }
-\references{
-  SAS Technical Support document TS-140:
-  ``The Record Layout of a Data Set in SAS Transport (XPORT) Format''
-  available at
-  \url{http://ftp.sas.com/techsup/download/technote/ts140.html}.
+\author{ Gregory R. Warnes \email{gr...@ra...}
+  based on \code{Hmisc:::sasxport.get} by Frank E. Harrell, Jr.}  
+\section{Note}{
+  This code provides a subset of the functionality of the
+  \code{sasxport.get} function in the Hmisc library.
 }
-\author{Saikat DebRoy \email{<sa...@st...>}}
 \seealso{
-  \code{\link{lookup.xport}}
+  \code{\link[foreign]{read.xport}},
+  \code{\link{label}},
+  \code{\link[Hmisc]{sas.get}},
+  \code{\link[Hmisc]{sasxport.get}},  
+  \code{\link{Dates}},
+  \code{\link{DateTimeClasses}},
+  \code{\link[chron]{chron}},
+  \code{\link[foreign]{lookup.xport}},
+  \code{\link[Hmisc]{contents}},
+  \code{\link[Hmisc]{describe}}
 }
 \examples{
 \dontrun{
-read.xport("transport")
+# -------
+# SAS code to generate test dataset:
+# -------
+# libname y SASV5XPT "test2.xpt";
+#
+# PROC FORMAT; VALUE race 1=green 2=blue 3=purple; RUN;
+# PROC FORMAT CNTLOUT=format;RUN;  * Name, e.g. 'format', unimportant;
+# data test;
+# LENGTH race 3 age 4;
+# age=30; label age="Age at Beginning of Study";
+# race=2;
+# d1='3mar2002'd ;
+# dt1='3mar2002 9:31:02'dt;
+# t1='11:13:45't;
+# output;
+#
+# age=31;
+# race=4;
+# d1='3jun2002'd ;
+# dt1='3jun2002 9:42:07'dt;
+# t1='11:14:13't;
+# output;
+# format d1 mmddyy10. dt1 datetime. t1 time. race race.;
+# run;
+# data z; LENGTH x3 3 x4 4 x5 5 x6 6 x7 7 x8 8;
+#    DO i=1 TO 100;
+#        x3=ranuni(3);
+#        x4=ranuni(5);
+#        x5=ranuni(7);
+#        x6=ranuni(9);
+#        x7=ranuni(11);
+#        x8=ranuni(13);
+#        output;
+#        END;
+#    DROP i;
+#    RUN;
+# PROC MEANS; RUN;
+# PROC COPY IN=work OUT=y;SELECT test format z;RUN; *Creates test2.xpt;
+# ------
+
+# Read this dataset from a local file:
+w <- read.xport('test2.xpt')
+
+\dontshow{
+library(Hmisc)
+w2 <- sasxport.get('test2.xpt')
+SASxport:::assert(identical(w,w2))
 }
+
+# Or read a copy of test2.xpt available on the web:
+url <- 'http://biostat.mc.vanderbilt.edu/cgi-bin/viewvc.cgi/*checkout*/Hmisc/trunk/tests/test2.xpt'
+w <- read.xport(url)
+
+\dontshow{ ## For testing only
+SASxport:::assert(identical(w2,w))
 }
-\keyword{file}
+
+\dontrun{
+## The Hmisc library provides many useful functions for interacting with
+## data imported from SAS via read.xport()
+library(Hmisc)
+
+describe(w$test)   # see labels, format names for dataset test
+
+lapply(w, describe)# see descriptive stats for both datasets
+
+contents(w$test)   # another way to see variable attributes
+lapply(w, contents)# show contents of both datasets
+
+options(digits=7)  # compare the following matrix with PROC MEANS output
+t(sapply(w$z, function(x)
+ c(Mean=mean(x),SD=sqrt(var(x)),Min=min(x),Max=max(x))))
+
+}
+
+}
+
+}
+\keyword{interface}
+\keyword{manip}

Added: trunk/SASxport/man/units.Rd
===================================================================
--- trunk/SASxport/man/units.Rd	                        (rev 0)
+++ trunk/SASxport/man/units.Rd	2007-08-08 18:53:04 UTC (rev 1122)
@@ -0,0 +1,64 @@
+\name{units}
+\alias{units}
+
+\alias{units.default}
+
+\alias{units<-}
+
+\alias{label}
+\alias{label<-}
+
+\alias{formats}
+\alias{formats<-}
+
+\alias{iformat}
+\alias{iformat<-}
+\title{
+Set or Retreive the Label, Format, iFormat, or Units Attribute of a Vector  
+}
+\description{
+  Sets or retrieves the \code{"label"}, \code{"format"},
+  \code{"iformat"}, or \code{"units"} attribute of an object.
+
+  More comprehensive support for object labels, formats, and units are
+  available in Frank Harrell's \code{Hmisc} package.
+}
+\usage{
+units(x, ...)
+\method{units}{default}(x, none='', \dots)
+units(x) <- value
+}
+\arguments{
+\item{x}{any object}
+\item{\dots}{ignored}
+\item{value}{the units of the object, or ""}
+\item{none}{value to which to set result if no appropriate attribute is
+  found}
+}
+\value{
+the units attribute of x, if any; otherwise, the \code{units} attribute of
+the \code{tspar} attribute of \code{x} if any; otherwise the value \code{none}
+}
+\author{Gregory R. Warnes \email{gr...@ra...} based
+  on code from the \code{Hmisc} library by Frank E. Harrell, Jr.}
+\seealso{\code{\link{label}}}
+\examples{
+fail.time <- c(10,20)
+units(fail.time) <- "Day"
+label(fail.time) <- 'Failure Time'
+fail.time
+\dontrun{
+
+# for a nice display
+library(Hmisc)
+describe(fail.time)
+
+
+
+f <- cph(Surv(fail.time, event) ~ xx)
+plot(xx,xx2,xlab=paste(label(xx),", ",units(xx),"s",sep=""))
+}
+}
+\keyword{utilities}
+\keyword{interface}
+% Converted by Sd2Rd version 1.21.


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1121] trunk/gtools

From: <wa...@us...> - 2007-08-08 13:52:48

Revision: 1121
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1121&view=rev
Author:   warnes
Date:     2007-08-08 06:52:47 -0700 (Wed, 08 Aug 2007)

Log Message:
-----------
Fix bug identified by R-2.6's check routings in binsearch()

Modified Paths:
--------------
    trunk/gtools/DESCRIPTION
    trunk/gtools/R/binsearch.R

Modified: trunk/gtools/DESCRIPTION
===================================================================
--- trunk/gtools/DESCRIPTION	2007-08-08 13:48:43 UTC (rev 1120)
+++ trunk/gtools/DESCRIPTION	2007-08-08 13:52:47 UTC (rev 1121)
@@ -1,7 +1,6 @@
 Package: gtools
 Title: Various R programming tools
 Description: Various R programming tools
-Depends: R
 Version: 2.4.0
 Author: Gregory R. Warnes. Includes R source code and/or documentation
         contributed by Ben Bolker and Thomas Lumley

Modified: trunk/gtools/R/binsearch.R
===================================================================
--- trunk/gtools/R/binsearch.R	2007-08-08 13:48:43 UTC (rev 1120)
+++ trunk/gtools/R/binsearch.R	2007-08-08 13:52:47 UTC (rev 1121)
@@ -105,7 +105,7 @@
           warning("Maximum number of iterations reached")
           retval$flag="Maximum number of iterations reached"
           retval$where=c(lo,hi)
-          retval$value=c(fun.lo,fun.hi)
+          retval$value=c(val.lo,val.hi)
         }
       else if( val.lo==target )
         {


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1120] trunk/gtools

From: <wa...@us...> - 2007-08-08 13:48:45

Revision: 1120
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1120&view=rev
Author:   warnes
Date:     2007-08-08 06:48:43 -0700 (Wed, 08 Aug 2007)

Log Message:
-----------
Add the binsearch(), previously in the genetics package.

Modified Paths:
--------------
    trunk/gtools/DESCRIPTION
    trunk/gtools/NAMESPACE
    trunk/gtools/NEWS

Added Paths:
-----------
    trunk/gtools/R/binsearch.R
    trunk/gtools/man/binsearch.Rd

Modified: trunk/gtools/DESCRIPTION
===================================================================
--- trunk/gtools/DESCRIPTION	2007-08-03 04:44:05 UTC (rev 1119)
+++ trunk/gtools/DESCRIPTION	2007-08-08 13:48:43 UTC (rev 1120)
@@ -2,7 +2,7 @@
 Title: Various R programming tools
 Description: Various R programming tools
 Depends: R
-Version: 2.3.1
+Version: 2.4.0
 Author: Gregory R. Warnes. Includes R source code and/or documentation
         contributed by Ben Bolker and Thomas Lumley
 Maintainer: Gregory R. Warnes <wa...@bs...>

Modified: trunk/gtools/NAMESPACE
===================================================================
--- trunk/gtools/NAMESPACE	2007-08-03 04:44:05 UTC (rev 1119)
+++ trunk/gtools/NAMESPACE	2007-08-08 13:48:43 UTC (rev 1120)
@@ -4,6 +4,7 @@
        addLast,
        ask,
        assert,
+       binsearch,
        capture,
        combinations,
        ddirichlet,

Modified: trunk/gtools/NEWS
===================================================================
--- trunk/gtools/NEWS	2007-08-03 04:44:05 UTC (rev 1119)
+++ trunk/gtools/NEWS	2007-08-08 13:48:43 UTC (rev 1120)
@@ -1,6 +1,12 @@
-SVN
-----
+gtools 2.4.0
+------------
 
+- Add binsearch() function, previously in the genetics() package.  
+
+
+gtoosl 2.3.1
+------------
+
 - Add ask() function to prompt the user and collect a single response.
 
 

Added: trunk/gtools/R/binsearch.R
===================================================================
--- trunk/gtools/R/binsearch.R	                        (rev 0)
+++ trunk/gtools/R/binsearch.R	2007-08-08 13:48:43 UTC (rev 1120)
@@ -0,0 +1,134 @@
+# $Id: binsearch.R 1295 2007-08-08 13:38:18Z warnes $
+
+binsearch <- function(fun, range, ..., target=0,
+                      lower=ceiling(min(range)),upper=floor(max(range)),
+                      maxiter=100, showiter=FALSE)
+    {
+
+      # initialize
+      lo <- lower
+      hi <- upper
+      counter <- 0
+      val.lo <- fun(lo,...)
+      val.hi <- fun(hi,...)
+
+      # check whether function is increasing or decreasing, & set sign
+      # appropriately.
+      if( val.lo > val.hi )
+        sign <- -1
+      else
+        sign <- 1
+
+      # check if value is outside specified range
+      if(target * sign < val.lo * sign)
+          outside.range <- TRUE
+      else if(target * sign >  val.hi * sign)
+          outside.range <- TRUE
+      else
+        outside.range <- FALSE
+
+      # iteratively move lo & high closer together until we run out of
+      # iterations, or they are adjacent, or they are identical
+      while(counter < maxiter && !outside.range )
+        {
+
+          counter <- counter+1
+
+          if(hi-lo<=1 || lo<lower || hi>upper) break;
+
+          center <- round((hi - lo)/2 + lo ,0  )
+          val <- fun(center, ...)
+
+          if(showiter)
+            {
+              cat("--------------\n")
+              cat("Iteration #", counter, "\n")
+              cat("lo=",lo,"\n")
+              cat("hi=",hi,"\n")
+              cat("center=",center,"\n")
+              cat("fun(lo)=",val.lo,"\n")
+              cat("fun(hi)=",val.hi,"\n")
+              cat("fun(center)=",val,"\n")
+            }
+
+          
+          if( val==target )
+            {
+              val.lo <- val.hi <- val
+              lo <- hi <- center
+              break;
+            }
+          else if( sign*val < sign*target )
+            {
+              lo <- center
+              val.lo <- val
+            }
+          else #( val > target )
+            {
+              hi <- center
+              val.hi <- val
+            }
+
+        if(showiter)
+          {
+            cat("new lo=",lo,"\n")
+            cat("new hi=",hi,"\n")
+            cat("--------------\n")
+          }
+          
+        }
+      
+      # Create return value
+      retval <- list()
+      retval$call <- match.call()
+      retval$numiter <- counter
+
+      if( outside.range )
+        {
+          if(target * sign < val.lo * sign)
+            {
+              warning("Reached lower boundary")
+              retval$flag="Lower Boundary"
+              retval$where=lo
+              retval$value=val.lo
+            }
+          else #(target * sign >  val.hi * sign)
+          {
+            warning("Reached upper boundary")
+            retval$flag="Upper Boundary"
+            retval$where=hi
+            retval$value=val.hi
+          }
+        }
+      else if( counter >= maxiter )
+        {
+          warning("Maximum number of iterations reached")
+          retval$flag="Maximum number of iterations reached"
+          retval$where=c(lo,hi)
+          retval$value=c(fun.lo,fun.hi)
+        }
+      else if( val.lo==target )
+        {
+          retval$flag="Found"
+          retval$where=lo
+          retval$value=val.lo
+        }
+      else if( val.hi==target )
+        {
+          retval$flag="Found"
+          retval$where=lo
+          retval$value=val.lo
+        }
+      else
+        {
+          retval$flag="Between Elements"
+          retval$where=c(lo, hi)
+          retval$value=c(val.lo, val.hi)
+        }
+      
+      return(retval)
+
+    }
+                 
+                                             
+

Added: trunk/gtools/man/binsearch.Rd
===================================================================
--- trunk/gtools/man/binsearch.Rd	                        (rev 0)
+++ trunk/gtools/man/binsearch.Rd	2007-08-08 13:48:43 UTC (rev 1120)
@@ -0,0 +1,103 @@
+% $Id: binsearch.Rd 1087 2006-11-11 04:09:59Z warnes $
+
+\name{binsearch}
+\alias{binsearch}
+\title{Binary Search}
+\description{
+  Search within a specified range to locate an integer parameter which
+  results in the the specified monotonic function obtaining a given value.
+}
+\usage{
+binsearch(fun, range, ..., target = 0, lower = ceiling(min(range)),
+          upper = floor(max(range)), maxiter = 100, showiter = FALSE)
+}
+\arguments{
+  \item{fun}{Monotonic function over which the search will be performed.}
+  \item{range}{2-element vector giving the range for the search.}
+  \item{\dots}{Additional parameters to the function \code{fun}.}
+  \item{target}{Target value for \code{fun}.  Defaults to 0.}
+  \item{lower}{Lower limit of search range. Defaults to \code{min(range)}.}
+  \item{upper}{Upper limit of search range. Defaults to \code{max(range)}.}
+  \item{maxiter}{ Maximum number of search iterations. Defaults to 100.}
+  \item{showiter}{ Boolean flag indicating whether the algorithm state
+    should be printed at each iteration. Defaults to FALSE.}
+}
+\details{
+  This function implements an extension to the standard binary search
+  algorithm for searching a sorted list.  The algorithm has been
+  extended to cope with cases where an exact match is not possible, to
+  detect whether that the function may be monotonic increasing or
+  decreasing and act appropriately, and to detect when the target value
+  is outside the specified range.
+
+  The algorithm initializes two variable \code{lo} and
+  \code{high} to the extremes values of \code{range}.  It then generates
+  a new value \code{center} halfway between \code{lo} and \code{hi}.  If
+  the value of \code{fun} at \code{center} exceeds \code{target}, it
+  becomes the new value for \code{lo}, otherwise it becomes the new
+  value for \code{hi}.  This process is iterated until \code{lo} and
+  \code{hi} are adjacent.  If the function at one or the other equals
+  the target, this value is returned, otherwise \code{lo}, \code{hi},
+  and the function value at both are returned.
+
+  Note that when the specified target value falls between integers, the
+  \em{two} closest values are returned.  If the specified target falls
+  outside of the specified \code{range}, the closest endpoint of the
+  range will be returned, and an warning message will be generated.  If
+  the maximum number if iterations was reached, the endpoints of the
+  current subset of the range under consideration will be returned.
+}
+\value{
+  A list containing:
+  \item{call}{How the function was called.}
+  \item{numiter}{The number of iterations performed}
+  \item{flag }{One of the strings,  "Found", "Between Elements",
+    "Maximum number of iterations reached", "Reached lower boundary", or
+    "Reached upper boundary."}
+  \item{where}{One or two values indicating where the search
+    terminated.}
+  \item{value}{Value of the function \code{fun} at the values of
+    \code{where}.}
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Gregory R. Warnes \email{wa...@bs...} }
+\note{This function often returns two values for \code{where} and
+  \code{value}.  Be sure to check the \code{flag} parameter to see what
+  these values mean.}
+\seealso{ \code{\link[base]{optim}}, \code{\link[base]{optimize}},
+  \code{\link[base]{uniroot}} }
+\examples{
+
+### Toy examples
+
+# search for x=10
+binsearch( function(x) x-10, range=c(0,20) )
+
+# search for x=10.1
+binsearch( function(x) x-10.1, range=c(0,20) )
+
+### Classical toy example
+
+# binary search for the index of 'M' among the sorted letters
+fun <- function(X) ifelse(LETTERS[X] > 'M', 1,
+                          ifelse(LETTERS[X] < 'M', -1, 0 ) )
+
+binsearch( fun, range=1:26 ) 
+# returns $where=13
+LETTERS[13]
+
+### Substantive example, from genetics
+\dontrun{
+library(genetics)
+# Determine the necessary sample size to detect all alleles with
+# frequency 0.07 or greater with probability 0.95.
+power.fun <- function(N) 1 - gregorius(N=N, freq=0.07)$missprob
+
+binsearch( power.fun, range=c(0,100), target=0.95 )
+
+# equivalent to
+gregorius( freq=0.07, missprob=0.05)
+}
+}
+\keyword{optimize}
+\keyword{programming}


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1118] trunk/SASxport/R/.Rhistory

From: <wa...@us...> - 2007-08-03 01:46:36

Revision: 1118
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1118&view=rev
Author:   warnes
Date:     2007-08-02 18:46:34 -0700 (Thu, 02 Aug 2007)

Log Message:
-----------
Remove stray .Rhistory file

Removed Paths:
-------------
    trunk/SASxport/R/.Rhistory

Deleted: trunk/SASxport/R/.Rhistory
===================================================================
--- trunk/SASxport/R/.Rhistory	2007-08-03 01:45:25 UTC (rev 1117)
+++ trunk/SASxport/R/.Rhistory	2007-08-03 01:46:34 UTC (rev 1118)
@@ -1,32 +0,0 @@
-options(DEBUG=TRUE)
-lookup.xport("xxx.dat", verbose=T)
-write.xport( abc, filename="xxx.dat", verbose=T)
-abc
-write.xport( abc, filename="xxx.dat", verbose=T)
-search()
-q("yes")
-library(SASxport)
-write.xport( abc, filename="xxx.dat", verbose=T)
-val
-write.xport( abc, filename="xxx.dat", verbose=T)
-val
-is.character(val)
-xport.numeric(val)
-xport.numeric
-xport.numeric(val)
-xport.numeric(val)()
-ls()
-xport.numeric
-xport.numeric(7)
-write.xport( abc, filename="xxx.dat", verbose=T)
-cal
-val
-write.xport( abc, filename="xxx.dat", verbose=T)
-val
-valLen
-is.character(val)
-is.numeric(val)
-xport.numeric(val)
-q("no")
-library(SASxport)
-example(write.xport)


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1117] trunk/SASxport/DESCRIPTION

From: <wa...@us...> - 2007-08-03 01:45:31

Revision: 1117
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1117&view=rev
Author:   warnes
Date:     2007-08-02 18:45:25 -0700 (Thu, 02 Aug 2007)

Log Message:
-----------
Acknowledge MetrumI support

Modified Paths:
--------------
    trunk/SASxport/DESCRIPTION

Modified: trunk/SASxport/DESCRIPTION
===================================================================
--- trunk/SASxport/DESCRIPTION	2007-08-03 01:45:03 UTC (rev 1116)
+++ trunk/SASxport/DESCRIPTION	2007-08-03 01:45:25 UTC (rev 1117)
@@ -5,7 +5,8 @@
 Date: 2007-07-28
 Author: Gregory R. Warnes <gr...@ra...>
 Maintainer: Gregory R. Warnes <gr...@ra...>
-Description: This package provides functions to list the contents of,
-        read, and write SAS export files.
+Description: This package provides functions to read, list contents of, and  
+             write SAS export files.  The creation of this package was funded
+             by Metrum Institute <http://metruminstitute.org>.
 License: GPL 2.0 or later
-Depends: gtools, foreign
\ No newline at end of file
+Depends: foreign
\ No newline at end of file


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1116] trunk/SASxport/NAMESPACE

From: <wa...@us...> - 2007-08-03 01:45:10

Revision: 1116
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1116&view=rev
Author:   warnes
Date:     2007-08-02 18:45:03 -0700 (Thu, 02 Aug 2007)

Log Message:
-----------
Add "assert" function

Modified Paths:
--------------
    trunk/SASxport/NAMESPACE

Modified: trunk/SASxport/NAMESPACE
===================================================================
--- trunk/SASxport/NAMESPACE	2007-08-03 01:44:23 UTC (rev 1115)
+++ trunk/SASxport/NAMESPACE	2007-08-03 01:45:03 UTC (rev 1116)
@@ -1,6 +1,7 @@
 export(
+       assert,
+       toSAS,
        write.xport,
-       toSAS
        )
 
 S3method(toSAS,numeric)


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1115] trunk/SASxport

From: <wa...@us...> - 2007-08-03 01:44:25

Revision: 1115
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1115&view=rev
Author:   warnes
Date:     2007-08-02 18:44:23 -0700 (Thu, 02 Aug 2007)

Log Message:
-----------
Add "assert" function to avoid dependenct on gtools.

Added Paths:
-----------
    trunk/SASxport/R/assert.R
    trunk/SASxport/man/assert.Rd

Added: trunk/SASxport/R/assert.R
===================================================================
--- trunk/SASxport/R/assert.R	                        (rev 0)
+++ trunk/SASxport/R/assert.R	2007-08-03 01:44:23 UTC (rev 1115)
@@ -0,0 +1,6 @@
+## useful function, raises an error if the FLAG expression is FALSE
+assert <- function( FLAG )
+  {
+    if(!all(FLAG))
+      stop("Failed Assertion") 
+  }

Added: trunk/SASxport/man/assert.Rd
===================================================================
--- trunk/SASxport/man/assert.Rd	                        (rev 0)
+++ trunk/SASxport/man/assert.Rd	2007-08-03 01:44:23 UTC (rev 1115)
@@ -0,0 +1,42 @@
+\name{assert}
+\alias{assert}
+\title{Generate an error if an expression is not true.}
+\description{
+  Generate an error if an expression is not true.
+}
+\usage{
+assert(FLAG)
+}
+\arguments{
+  \item{FLAG}{ Expression that should evaluate to a boolean vector}
+}
+\details{
+  Assert generate an error if its aregument does not evaluate to 
+  boolean (vector) containing only \code{TRUE} values.  This is useful
+  for defensinve programming as it provides a mechanism for checking
+  that certain facts, the 'assertions', do in fact hold.  Checking of 
+  'assertions' is an important tool in the development of robust program
+  code.
+}
+\value{
+  None.  Evaluated only for its side effect.
+}
+\author{Gregory R. Warnes \email{wa...@bs...} }
+\seealso{ \code{\link[base]{stop}}, \code{\link[base]{warning}} }
+\examples{
+
+## Trivial example
+posSqrt <- function(x)
+  {
+    assert(x>=0)
+    sqrt(x)
+  }
+
+posSqrt(1:10) # works fine, no messages
+\dontrun{
+posSqrt(-5:5) # generates an error, since the asssertion is not met
+}
+
+
+}
+\keyword{programming}


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

[R-gregmisc-users] SF.net SVN: r-gregmisc: [1114] trunk/SASxport

From: <wa...@us...> - 2007-08-03 01:29:42

Revision: 1114
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1114&view=rev
Author:   warnes
Date:     2007-08-02 18:29:24 -0700 (Thu, 02 Aug 2007)

Log Message:
-----------
Correct some typos.

Modified Paths:
--------------
    trunk/SASxport/man/toSAS.Rd
    trunk/SASxport/src/cnxptiee.c
    trunk/SASxport/src/writeSAS.c

Modified: trunk/SASxport/man/toSAS.Rd
===================================================================
--- trunk/SASxport/man/toSAS.Rd	2007-08-03 00:40:42 UTC (rev 1113)
+++ trunk/SASxport/man/toSAS.Rd	2007-08-03 01:29:24 UTC (rev 1114)
@@ -1,12 +1,12 @@
 \name{toSAS.default}
-alias{toSAS}
-alias{toSAS.numeric}
-alias{toSAS.logical}
-alias{toSAS.character}
-alias{toSAS.factor}
-alias{toSAS.POSIXt}
-alias{toSAS.Date}
-alias{toSAS.default}
+\alias{toSAS}
+\alias{toSAS.numeric}
+\alias{toSAS.logical}
+\alias{toSAS.character}
+\alias{toSAS.factor}
+\alias{toSAS.POSIXt}
+\alias{toSAS.Date}
+\alias{toSAS.default}
 \title{Convert R data object for storage in SAS xport file}
 \description{
   The \code{toSAS} methods control how R objects and data types are

Modified: trunk/SASxport/src/cnxptiee.c
===================================================================
--- trunk/SASxport/src/cnxptiee.c	2007-08-03 00:40:42 UTC (rev 1113)
+++ trunk/SASxport/src/cnxptiee.c	2007-08-03 01:29:24 UTC (rev 1114)
@@ -1,6 +1,6 @@
 #include <stdio.h>
 #include <string.h>
-#import "cnxptiee.h"
+#include "cnxptiee.h"
 
 
 

Modified: trunk/SASxport/src/writeSAS.c
===================================================================
--- trunk/SASxport/src/writeSAS.c	2007-08-03 00:40:42 UTC (rev 1113)
+++ trunk/SASxport/src/writeSAS.c	2007-08-03 01:29:24 UTC (rev 1114)
@@ -27,11 +27,9 @@
 #include <R.h>
 #include <Rinternals.h>
 
-//#import "cnxptiee.h"
-
 extern int cnxptiee(char *from, int fromtype, char *to, int totype);
 
-#import "writeSAS.h"
+#include "writeSAS.h"
 
 
 


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

3 messages has been excluded from this view by a project administrator.

Flat | Threaded

<< < 1 .. 33 34 35 36 37 .. 42 > >> (Page 35 of 42)