The R Project SVN R

Rev

Rev 19717 | Rev 32700 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
19139 maechler 1 
/*
2 
 *  R : A Computer Language for Statistical Data Analysis
3 
 *  Copyright (C) 2002     the R Development Core Team
4 
 *
5 
 *  This program is free software; you can redistribute it and/or modify
6 
 *  it under the terms of the GNU General Public License as published by
7 
 *  the Free Software Foundation; either version 2 of the License, or
8 
 *  (at your option) any later version.
9 
 *
10 
 *  This program is distributed in the hope that it will be useful,
11 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
12 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 
 *  GNU General Public License for more details.
14 
 *
15 
 *  You should have received a copy of the GNU General Public License
16 
 *  along with this program; if not, write to the Free Software
17 
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
18 
 *
19 
 * Written by Jonathan Rougier, email J.C.Rougier@durham.ac.uk
20 
*/
19133 maechler 21 
#ifdef HAVE_CONFIG_H
22 
#include <config.h>
23 
#endif
24 
 
25 
#include <Defn.h>
26 
 
27 
#define MAXLINE MAXELTSIZE
28 
 
19717 ripley 29 
/* Simple wrapper for C sprintf function: now (1.6.0) checks the
30 
   types and handles the R specials.
19133 maechler 31 
*/
32 
SEXP do_sprintf(SEXP call, SEXP op, SEXP args, SEXP env)
33 
{
34 
    int nargs;
35 
    char *formatString;
36 
    char fmt[MAXLINE+1], bit[MAXLINE+1], outputString[MAXLINE+1] = "";
37 
    size_t n, cur, chunk;
38 
 
39 
    SEXP format, ans;
40 
 
41 
    /* grab the format string */
42 
 
43 
    nargs = length(args);
44 
    format = CAR(args);
45 
    if (!isString(format) || LENGTH(format) != 1)
46 
	errorcall(call, "`fmt' is not a character string of length 1");
47 
    formatString = CHAR(STRING_ELT(format, 0));
48 
    n = strlen(formatString);
49 
    if (n > MAXLINE)
50 
	errorcall(call, "string length exceeds maximal buffer length %d",
51 
		  MAXLINE);
52 
 
53 
    /* process the format string */
54 
    for (cur = 0; cur < n; cur += chunk) {
55 
 
56 
	if (formatString[cur] == '%') { /* handle special format command */
57 
 
58 
	    if (cur < n - 1 && formatString[cur + 1] == '%') {
59 
		/* take care of %% in the format */
60 
		chunk = 2;
61 
		strcpy(bit, "%");
62 
	    }
63 
	    else {
64 
		/* recognise selected types from Table B-1 of K&R */
65 
 
66 
		chunk = strcspn(formatString + cur, "disfeEgG") + 1;
67 
		if (cur + chunk > n)
68 
		    errorcall(call, "unrecognised format at end of string");
69 
 
70 
		strncpy(fmt, formatString + cur, chunk);
71 
		fmt[chunk] = '\0';
72 
 
73 
		if (--nargs > 0)
74 
		    args = CDR(args);
75 
		else errorcall(call, "not enough arguments");
76 
 
19717 ripley 77 
		if (LENGTH(CAR(args)) < 1)
78 
		    error("zero-length argument");
19133 maechler 79 
		switch(TYPEOF(CAR(args))) {
80 
		case LGLSXP:
19717 ripley 81 
		{
82 
		    int x = LOGICAL(CAR(args))[0];
83 
		    if (strcspn(fmt, "di") >= strlen(fmt))
84 
			error("%s", "use format %d or %i for logical objects");
85 
		    if (x == NA_LOGICAL) {
86 
			fmt[chunk-1] = 's';
87 
			sprintf(bit, fmt, "NA");
88 
		    } else
89 
			sprintf(bit, fmt, x);
90 
		    break;
91 
		}
19133 maechler 92 
		case INTSXP:
19717 ripley 93 
		{
94 
		    int x = INTEGER(CAR(args))[0];
95 
		    if (strcspn(fmt, "di") >= strlen(fmt))
96 
			error("%s", "use format %d or %i for integer objects");
97 
		    if (x == NA_INTEGER) {
98 
			fmt[chunk-1] = 's';
99 
			sprintf(bit, fmt, "NA");
100 
		    } else
25629 ripley 101 
			sprintf(bit, fmt, x);
19133 maechler 102 
		    break;
19717 ripley 103 
		}
19133 maechler 104 
		case REALSXP:
19717 ripley 105 
		{
106 
		    double x = REAL(CAR(args))[0];
107 
		    if (strcspn(fmt, "feEgG") >= strlen(fmt))
108 
			error("%s", "use format %f, %e or %g for numeric objects");
109 
		    if (R_FINITE(x)) {
110 
			sprintf(bit, fmt, x);
111 
		    } else {
112 
			char *p = strchr(fmt, '.');
113 
			if (p) {
114 
			    *p++ = 's'; *p ='\0';
115 
			} else
116 
			    fmt[chunk-1] = 's';
117 
			if (ISNA(x)) {
118 
			    if (strcspn(fmt, " ") < strlen(fmt))
119 
				sprintf(bit, fmt, " NA");
120 
			    else
121 
				sprintf(bit, fmt, "NA");
122 
			} else if (ISNAN(x)) {
123 
			    if (strcspn(fmt, " ") < strlen(fmt))
124 
				sprintf(bit, fmt, " NaN");
125 
			    else
126 
				sprintf(bit, fmt, "NaN");
127 
			} else if (x == R_PosInf) {
128 
			    if (strcspn(fmt, "+") < strlen(fmt))
129 
				sprintf(bit, fmt, "+Inf");
130 
			    else if (strcspn(fmt, " ") < strlen(fmt))
131 
				sprintf(bit, fmt, " Inf");
132 
			    else
133 
				sprintf(bit, fmt, "Inf");
134 
			} else if (x == R_NegInf)
135 
			    sprintf(bit, fmt, "-Inf");
136 
		    }
19133 maechler 137 
		    break;
19717 ripley 138 
		}
19133 maechler 139 
		case STRSXP:
19717 ripley 140 
		    /* NA_STRING will be printed as `NA' */
141 
		    if (strcspn(fmt, "s") >= strlen(fmt))
142 
			error("%s", "use format %s for character objects");
19133 maechler 143 
		    sprintf(bit, fmt, CHAR(STRING_ELT(CAR(args), 0)));
144 
		    break;
145 
		default:
146 
		    errorcall(call, "unsupported type");
147 
		    break;
148 
		}
149 
	    }
150 
	}
151 
	else { /* not '%' : handle string part */
152 
 
153 
	    chunk = strcspn(formatString + cur, "%");
154 
	    strncpy(bit, formatString + cur, chunk);
155 
	    bit[chunk] = '\0';
156 
	}
157 
 
158 
	if (strlen(outputString) + strlen(bit) > MAXLINE)
159 
	    errorcall(call, "String length exceeds buffer");
160 
	strcat(outputString, bit);
161 
    }
162 
 
163 
    /* return outputString as SEXP */
164 
 
165 
    if (nargs > 1)
166 
	warning("Unused arguments");
167 
 
168 
    PROTECT(ans = allocVector(STRSXP, 1));
169 
    SET_STRING_ELT(ans, 0, mkChar(outputString));
170 
    UNPROTECT(1);
171 
    return ans;
172 
}