Re: R-alpha: printf etc ---> My formatC(..) submission to Statlib

Martin Maechler (maechler@stat.math.ethz.ch)
Thu, 21 Nov 96 18:55:47 +0100


Date: Thu, 21 Nov 96 18:55:47 +0100
Message-Id: <9611211755.AA00935@>
From: Martin Maechler <maechler@stat.math.ethz.ch>
To: Friedrich.Leisch@ci.tuwien.ac.at
In-Reply-To: <199611201241.NAA13044@galadriel.ci.tuwien.ac.at> (message from
Subject: Re: R-alpha: printf etc ---> My formatC(..) submission to Statlib

I had the same problem with S-plus, years ago.

Since then, they (StatSci) have introduced a greatly improved  
format.default, but I still occasionally have need of my  formatC 
function ( + C-routine)

---
unfortunately, I don't have the time right now to test the code in R,
it is well tested under S-plus though....

Here comes  (a bit newer than  ..statlib../S/formatC ) :

#!/bin/sh
# This is a shell archive (produced by GNU sharutils 4.2).
# To extract the files from this archive, save it to some FILE, remove
# everything before the `!/bin/sh' line above, then type `sh FILE'.
#
# Made on 1996-11-21 16:21 MET by <maechler@stat.math.ethz.ch>.
# Source directory was `/tmp_mnt/users/home2/staff/maechler/S/C-Progs/formatC'.
#
# Existing files will *not* be overwritten unless `-c' is specified.
#
# This shar contains:
# length mode       name
# ------ ---------- ------------------------------------------
#   1342 -rw-r--r-- README
#   1571 -rw-r--r-- Makefile
#   2395 -rw-r--r-- str_signif.c
#   2654 -r--r--r-- formatC.d
#   3225 -rw-r--r-- formatC.S
#
save_IFS="${IFS}"
IFS="${IFS}:"
gettext_dir=FAILED
locale_dir=FAILED
first_param="$1"
for dir in $PATH
do
  if test "$gettext_dir" = FAILED && test -f $dir/gettext \
     && ($dir/gettext --version >/dev/null 2>&1)
  then
    set `$dir/gettext --version 2>&1`
    if test "$3" = GNU
    then
      gettext_dir=$dir
    fi
  fi
  if test "$locale_dir" = FAILED && test -f $dir/shar \
     && ($dir/shar --print-text-domain-dir >/dev/null 2>&1)
  then
    locale_dir=`$dir/shar --print-text-domain-dir`
  fi
done
IFS="$save_IFS"
if test "$locale_dir" = FAILED || test "$gettext_dir" = FAILED
then
  echo=echo
else
  TEXTDOMAINDIR=$locale_dir
  export TEXTDOMAINDIR
  TEXTDOMAIN=sharutils
  export TEXTDOMAIN
  echo="$gettext_dir/gettext -s"
fi
touch -am 1231235999 $$.touch >/dev/null 2>&1
if test ! -f 1231235999 && test -f $$.touch; then
  shar_touch=touch
else
  shar_touch=:
  echo
  $echo 'WARNING: not restoring timestamps.  Consider getting and'
  $echo "installing GNU \`touch', distributed in GNU File Utilities..."
  echo
fi
rm -f 1231235999 $$.touch
#
if mkdir _sh00584; then
  $echo 'x -' 'creating lock directory'
else
  $echo 'failed to create lock directory'
  exit 1
fi
# ============= README ==============
if test -f 'README' && test "$first_param" != -c; then
  $echo 'x -' SKIPPING 'README' '(file already exists)'
else
  $echo 'x -' extracting 'README' '(text)'
  sed 's/^X//' << 'SHAR_EOF' > 'README' &&
formatC: A more flexible 'format' for S / Splus
=======
X
This contains S and C source for "formatC".
X
After unpacking the files,
you should be able to write  'make'  to fully install it in the current
directory.
'make'	will also automatically run the examples in the help file.
X
You may need to edit 'Makefile' ....
X
X
The files  *.d are  HELP files and should be copied into the 
appropriate  .Data/.Help/ directory (under names WITHOUT ending '.d').
X
-------------------------------------------------------------------------------
Copyright (C) Martin Maechler, 1994
X
This code is to be understood as Free Software in the sense of GNU Copyright:
You can freely use and redistribute this software for non-commercial
purposes only.
You even are allowed to enhance and improve it as much as you like,
as long as you distribute the source code together with the software.
X
I want you to preserve the copyright of the original author(s), and
encourage you very much to send me any improvements by e-mail.
X
I'll willing to help with problems and bugs, too.
-------------------------------------------------------------------------------
Martin Maechler <maechler@stat.math.ethz.ch>		 <><	 _
Seminar fuer Statistik, SOL F5				       _| |_
ETH (Federal Inst. Technology)	8092 Zurich	 SWITZERLAND  |_   _|
phone: x-41-1-632-3408		fax: ...-1086			|_|
SHAR_EOF
  $shar_touch -am 0907181994 'README' &&
  chmod 0644 'README' ||
  $echo 'restore of' 'README' 'failed'
  if ( md5sum --help 2>&1 | grep 'sage: md5sum \[' ) >/dev/null 2>&1 \
  && ( md5sum --version 2>&1 | grep -v 'textutils 1.12' ) >/dev/null; then
    md5sum -c << SHAR_EOF >/dev/null 2>&1 \
    || $echo 'README:' 'MD5 check failed'
236522ee8e0861edd807ffd467e5f18b  README
SHAR_EOF
  else
    shar_count="`LC_ALL= LC_CTYPE= LANG= wc -c < 'README'`"
    test 1342 -eq "$shar_count" ||
    $echo 'README:' 'original size' '1342,' 'current size' "$shar_count!"
  fi
fi
# ============= Makefile ==============
if test -f 'Makefile' && test "$first_param" != -c; then
  $echo 'x -' SKIPPING 'Makefile' '(file already exists)'
else
  $echo 'x -' extracting 'Makefile' '(text)'
  sed 's/^X//' << 'SHAR_EOF' > 'Makefile' &&
# Makefile for 'formatC'
# ~~~~~~~~
#
S = S
S = Splus #-- uncomment this line if you are NOT using Splus --
X
CC = gcc
CFLAGS = -O -Wall
X
#-- edit the following line if you want to install in a different place:
DATADIR = ./.Data# == ../goodies.Data
X
##--------------- you should hardly edit below this line ! ------------------
X
HELPDIR = ${DATADIR}/.Help
X
#--- this is for 'one name' packages :
Sname = formatC
X
Ssrc = $(Sname).d  $(Sname).S
Sobj = ${DATADIR}/$(Sname) ${HELPDIR}/$(Sname)
OBJ  = str_signif.o
X
pkg = README Makefile str_signif.c $(Ssrc)
X
all: $(OBJ) $(Sobj) S-example.out
###
X
${DATADIR}/$(Sname): ${HELPDIR} $(Sname).S
X	echo "attach('${DATADIR}',1)" > att.cmd
X	DN=`dirname ${DATADIR}`; if [ $$DN = '.' ]; then DN=`pwd`;fi ;\
X	sed s%FORMATC.HOME%\"$$DN\"%  $(Sname).S \
X	 | cat att.cmd - | $(S) > S-sess.log
X	rm -f att.cmd
X
X
${HELPDIR}/$(Sname):  ${HELPDIR} $(Sname).d
X	cp  $(Sname).d   $@
X	-echo "help.findsum('$(DATADIR)')" | $(S)
${HELPDIR}: ; -mkdir -p ${HELPDIR}
X
S-example.out: ${DATADIR}/$(Sname) ex.S
X	-$(S) < ex.S | tee S-example.out
ex.S: $(Sname).d
X	echo "options(echo = T); find($(Sname))" > $@
X	sed '1,/^\.EX/d; /^\.KW/,$$d' $(Sname).d >> $@
X
shar: $(pkg)
X	mv $(Sname).S $(Sname)+.S
X	sed '/DEBUG/d' $(Sname)+.S > $(Sname).S
X	shar $(pkg) > $(Sname).shar
X	mv $(Sname)+.S  $(Sname).S
X
clean: ; rm -f *.shar *.o core ex.S  S-example.out S-sess.log att.cmd
realclean: clean
X	rm -f -r $(Sobj)
X	-ci $(Ssrc) -m'automatic check-in by make'
X	-@echo ""
X	-@echo "NOTE: You must check-out ('co') $(Ssrc) by hand"
X	-@echo "----  if you don't use GNU make"
SHAR_EOF
  $shar_touch -am 1121162196 'Makefile' &&
  chmod 0644 'Makefile' ||
  $echo 'restore of' 'Makefile' 'failed'
  if ( md5sum --help 2>&1 | grep 'sage: md5sum \[' ) >/dev/null 2>&1 \
  && ( md5sum --version 2>&1 | grep -v 'textutils 1.12' ) >/dev/null; then
    md5sum -c << SHAR_EOF >/dev/null 2>&1 \
    || $echo 'Makefile:' 'MD5 check failed'
c036d7a8cd921802434f6e927f855154  Makefile
SHAR_EOF
  else
    shar_count="`LC_ALL= LC_CTYPE= LANG= wc -c < 'Makefile'`"
    test 1571 -eq "$shar_count" ||
    $echo 'Makefile:' 'original size' '1571,' 'current size' "$shar_count!"
  fi
fi
# ============= str_signif.c ==============
if test -f 'str_signif.c' && test "$first_param" != -c; then
  $echo 'x -' SKIPPING 'str_signif.c' '(file already exists)'
else
  $echo 'x -' extracting 'str_signif.c' '(text)'
  sed 's/^X//' << 'SHAR_EOF' > 'str_signif.c' &&
/*
X  Originally from Bill Dunlap, bill@stat.washington.edu Wed Feb 21 18:08:43 1990
X  Much improved by Martin Maechler
X  ----
X     type    "double", "single" or "integer" (S - numeric `mode').
X     width   The total field width;
X             width < 0  means to left justify the number in this field
X	     (equivalent to flag = "-").
X	     It is possible that the result will be longer than this,
X	     but that should only happen in reasonable cases.
X     digits  The desired number of digits after the decimal point.
X	     digits < 0 uses the default for C, namely 6 digits.
X     format  Must be "d" (for integers) or "f", "e","E", "g", "G" (for 'real')
X             "f" gives numbers in the usual 	xxx.xxx format;
X	     "e" and "E" give  n.ddde<nn> or n.dddE<nn> (scientific format);
X	     "g" and "G" puts them into scientific format
X	      only if it saves space to do so.
X     flag    Format modifier as in K&R "C", 2nd ed., p.243;
X             e.g., "0" pads leading zeros; "-" does left adjustment
X	     the other possible flags are  "+", " ", and "#".
*/
X
#include <stdio.h>
#include <string.h>
X
void
X str_signif(x, n, type, width, digits, format, flag, result)
/**********/
X     char *x ; /* really "type *", not "char *" */
X     long *n;
X     char **type ;
X     long *width, *digits ;
X     char **format, **flag;
X     char **result ;
{
X  int wid = (int)*width;
X  int dig = (int)*digits;
X  long i, nn = *n;
X  char * form;
X
X  if (wid == 0)  Recover("Width cannot be zero", NULL) ;
X
X  if (strcmp("d", *format) == 0) { /*---------------- integer -----------*/
X    if (strlen(*flag) == 0)  form = "%*d";
X    else { form = "% *d"; form[1] = *flag[0]; }
X    if (strcmp("integer", *type) == 0)
X      for (i=0; i < nn; i++)
X	sprintf(result[i], form, wid, (int)((long *)x)[i]) ;
X    else 
X      Recover("`type' must be \"integer\" for  \"d\"-format", NULL);
X  } else {
X    if (strlen(*flag) == 0) { 
X      form = "%*.*#";
X      form[4] = *format[0];
X    } else { 
X      form = "% *.*#";
X      form[1] = *flag[0];
X      form[5] = *format[0];
X    }
X    if (strcmp("double", *type) == 0)
X      for (i=0; i < nn; i++)
X	sprintf(result[i], form, wid, dig, ((double *)x)[i]) ;
X    else if (strcmp("single", *type) == 0)
X      for (i=0; i < nn; i++)
X	sprintf(result[i], form, wid, dig, ((float *)x)[i]) ;
X    else 
X      Recover("`type' must be \"double\" or \"single\" for this format", NULL);
X  }
}
X
SHAR_EOF
  $shar_touch -am 0907164094 'str_signif.c' &&
  chmod 0644 'str_signif.c' ||
  $echo 'restore of' 'str_signif.c' 'failed'
  if ( md5sum --help 2>&1 | grep 'sage: md5sum \[' ) >/dev/null 2>&1 \
  && ( md5sum --version 2>&1 | grep -v 'textutils 1.12' ) >/dev/null; then
    md5sum -c << SHAR_EOF >/dev/null 2>&1 \
    || $echo 'str_signif.c:' 'MD5 check failed'
5e52b1871f18f089c5ff71ccef377314  str_signif.c
SHAR_EOF
  else
    shar_count="`LC_ALL= LC_CTYPE= LANG= wc -c < 'str_signif.c'`"
    test 2395 -eq "$shar_count" ||
    $echo 'str_signif.c:' 'original size' '2395,' 'current size' "$shar_count!"
  fi
fi
# ============= formatC.d ==============
if test -f 'formatC.d' && test "$first_param" != -c; then
  $echo 'x -' SKIPPING 'formatC.d' '(file already exists)'
else
  $echo 'x -' extracting 'formatC.d' '(text)'
  sed 's/^X//' << 'SHAR_EOF' > 'formatC.d' &&
X.\" @(#)Copyright (c), 1994, Martin Maechler, ETH Zurich.-
X.\" $Id: formatC.d,v 1.3 1994/09/07 15:58:15 maechler Exp $
X.BG
X.FN formatC
X.TL
Numeric to character conversion with flexibility of C's printf.
X.DN
Similar to format(.), there is more flexibility, using C's printf(.).
The choice of exponential representation is made automatically.
X Can also be used to convert strings to a 'fixed' length.
X.CS
formatC(x, digits=NULL, width=max(0,digits)+1, 
X        format=NULL, flag="", mode=NULL)
X.RA
X.AG x
an atomic numerical or character object, typically a vector of real numbers.
X.OA
X.AG digits
The desired number of digits after the decimal point.
DEFAULT: 2 for integer, 4 for real numbers.
digits < 0 uses the default for C, namely 6 digits.
X.AG width
The total field width;
width < 0 means to left justify the number in this field
(equivalent to flag = `"-"').
It is possible that the result will be longer than this, 
but that should only happen in reasonable cases.
X.AG format
character = `"d"' (for integers) 
or `"f"', `"e"',`"E"', `"g"', `"G"' (for 'real'), or `"s"' (for strings).
X `"f"' gives numbers in the usual 	xxx.xxx format;
X `"e"' and `"E"' give  n.ddde<nn> or n.dddE<nn> (scientific format);
X `"g"' and `"G"' puts `x[i]' into scientific format
X.I only
if it saves space to do so. 
X.AG flag
Format modifier as in K&R, 2nd ed.,p.243. 
`"0"' pads leading zeros; `"-"' does left adjustment, 
others are  `"+"', `" "', and `"#"'.
X.AG mode
mode  `"double"', `"single"', `"integer"' or `"character"' =^= storage.mode.
Default: Automatic.
X.RT
character object of same size and attributes as `x'.
X.DT
Contrary to format, each number is individually formatted.
A for loop over each element of `x[]', calling `sprintf(..)'
is done in the  C function `str_signif'.
X
For character arguments, simple (left or right) "padding" with white space
is done.
X.SH BUGS
Does not yet work for complex numbers.
X.SH REFERENCES
Kernighan and Richie (1990). 
X.ul
The C Programming Language,
2nd ed; Prentice Hall, sec. B1.2, p.243-4
X.SH AUTHOR
original: Bill Dunlap <bill\@stat.washington.edu>, 2/1990;
X current: Martin Maechler <maechler\@stat.math.ethz.ch>
X          Seminar fuer Statistik, ETH Zurich, SWITZERLAND
X.SA
`format', `paste', `cat', `print'.
X.EX
xx <- pi* 10^(-5:4)
options(digits=4)			#-- only for format(.)
cbind(format(xx), formatC(xx))		#-- see the difference!
cbind(formatC(xx, wid= 9, flag='-'))			#-- left-justified
cbind(formatC(xx, dig=5, wid=8, format="f",flag='0'))	#-- pad leading 0.
X
cbind(formatC(names(cu.specs), wid=12))	#---- string formatting ----------
cbind(formatC(names(cu.specs), wid= 8, flag="-"))
X.KW print
X.KW character
X.WR
SHAR_EOF
  $shar_touch -am 0908102794 'formatC.d' &&
  chmod 0444 'formatC.d' ||
  $echo 'restore of' 'formatC.d' 'failed'
  if ( md5sum --help 2>&1 | grep 'sage: md5sum \[' ) >/dev/null 2>&1 \
  && ( md5sum --version 2>&1 | grep -v 'textutils 1.12' ) >/dev/null; then
    md5sum -c << SHAR_EOF >/dev/null 2>&1 \
    || $echo 'formatC.d:' 'MD5 check failed'
41c644e65f16aa12e869b145d0d38a3b  formatC.d
SHAR_EOF
  else
    shar_count="`LC_ALL= LC_CTYPE= LANG= wc -c < 'formatC.d'`"
    test 2654 -eq "$shar_count" ||
    $echo 'formatC.d:' 'original size' '2654,' 'current size' "$shar_count!"
  fi
fi
# ============= formatC.S ==============
if test -f 'formatC.S' && test "$first_param" != -c; then
  $echo 'x -' SKIPPING 'formatC.S' '(file already exists)'
else
  $echo 'x -' extracting 'formatC.S' '(text)'
  sed 's/^X//' << 'SHAR_EOF' > 'formatC.S' &&
#### formatC -- Source --
#### ~~~~~~~ -- ====== $Id: formatC.S,v 1.13 1996/07/04 12:38:58 maechler Exp $
X
###--- These are useful as well :
X
ccat <- function(...) paste(..., collapse = "", sep = "")
vcat <- function(vec, sep = " ") paste(vec, collapse = sep)
str.vec <- function(name, digits = options()$digits)
X  paste(paste(deparse(substitute(name))), "=",
X	paste(f.format(name, digits = digits), collapse = " "))
signi <- function(x, digits = 6) round(x, digits - trunc(log10(abs(x))))
X
###------------------------------------------------------------------------
X
bl.string <- function(no)  paste(rep(" ", no), collapse = "")
X
formatC <- function(x, digits = NULL, width = max(0, digits) + 1,
X		    format = NULL, flag = "", mode = NULL)
{
X  ## ----- $Id: formatC.S,v 1.13 1996/07/04 12:38:58 maechler Exp $ ---
X  ## Purpose: Numeric to character conversion with flexibility of C's printf.
X  ## -------------------------------------------------------------------------
X  ## Arguments: x: numeric,  digits: # dig. after '.',  width: of field
X  ##	format: "d" (integers) or "f", "e","E", "g", "G" (real), or "s" (string)
X  ## USE  '?formatC'  for detailed on-line help!
X  ## -------------------------------------------------------------------------
X  ## Authors: Bill Dunlap, then Martin Maechler <maechler@stat.math.ethz.ch>
X  ##
X  if (is.null(x)) return("")
X  n <- length(x)
X  if (missing(mode)) mode <- storage.mode(x)
X  else if (any(mode == c("double", "single", "integer")))
X    storage.mode(x) <- mode
X  else stop("`mode' must be \"double\", \"single\" or \"integer\"")
X
X  if(mode=="character" || (!is.null(format) && format=="s")) {
X    if(mode != "character") {
X      warning("should give 'character' argument for format='s' -- COERCE")
X      x <- as.character(x)
X    }
X    nc <- nchar(x)			#-- string lengths
X    if(width<0) { flag <- "-"; width <- -width }
X    pad <- sapply(pmax(0,width - nc), bl.string)
X    if(flag=="-") return(paste(x, pad, sep="")) #-- LEFT justify -----
X      else	        return(paste(pad, x, sep="")) #-- RIGHT justify (normal)
X  }
X
X  some.special <- !all(Ok <- is.finite(x))
X  if(some.special) {
X    nQ <- nchar(rQ <- as.character(x[!Ok]))
X    nX <- pmax(width - nQ, 0)	#-- number of characters to add
X    x[!Ok] <- 0
X  }
X  if (missing(format)|| is.null(format))
X    format <- if (mode == "integer") "d" else "g"
X  else {
X    if (any(format == c("f","e","E","g","G"))) {
X      if (mode == "integer")
X	mode <- storage.mode(x) <- "single"
X    } else if (format == "d") {
X      if (mode != "integer") mode <- storage.mode(x) <- "integer"
X    } else  stop('`format\' must be in {"f","e","E","g","G", "s"}')
X  }
X  if (missing(digits)|| is.null(digits))
X    digits <- if (mode == "integer") 2 else 4
X  if (width == 0)  stop("`width' must not be 0")
X  if (!is.loaded(C.symbol("str_signif")))
X    dyn.load(paste(FORMATC.HOME, "str_signif.o", sep="/"))
X  r <- .C("str_signif",
X	x = x,
X	n = n,
X	mode	= as.character(mode),
X	width	= as.integer(width),
X	digits	= as.integer(digits),
X	format	= as.character(format),
X	flag	= as.character(flag),
X	result	= rep(bl.string(abs(width)+10), n)) $ result
X  if (some.special)  r[!Ok] <- rQ
X  if (!is.null(x.atr <- attributes(x)))  attributes(r) <- x.atr
X  r
}
SHAR_EOF
  $shar_touch -am 1121162196 'formatC.S' &&
  chmod 0644 'formatC.S' ||
  $echo 'restore of' 'formatC.S' 'failed'
  if ( md5sum --help 2>&1 | grep 'sage: md5sum \[' ) >/dev/null 2>&1 \
  && ( md5sum --version 2>&1 | grep -v 'textutils 1.12' ) >/dev/null; then
    md5sum -c << SHAR_EOF >/dev/null 2>&1 \
    || $echo 'formatC.S:' 'MD5 check failed'
46aabc4f37fff081030193444fd5fd29  formatC.S
SHAR_EOF
  else
    shar_count="`LC_ALL= LC_CTYPE= LANG= wc -c < 'formatC.S'`"
    test 3225 -eq "$shar_count" ||
    $echo 'formatC.S:' 'original size' '3225,' 'current size' "$shar_count!"
  fi
fi
rm -fr _sh00584
exit 0
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
r-testers mailing list -- For info or help, send "info" or "help",
To [un]subscribe, send "[un]subscribe"
(in the "body", not the subject !)  To: r-testers-request@stat.math.ethz.ch
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-