The R Project SVN – R – Diff – /trunk/src/appl/stem.c


/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1997-2000   Robert Gentleman, Ross Ihaka and the
 *                            R Development Core Team
 *
 *  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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 */
 
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
 
#include <Rmath.h> /* for imin2 and imax2 */
#include <R_ext/Print.h> /* for Rprintf */
#include <R_ext/Utils.h> /* for R_rsort */
 
#include <R_ext/Applic.h>
 
static void stem_print(int close, int dist, int ndigits)
{
    if((close/10 == 0) && (dist < 0))
	Rprintf("  %*s | ", ndigits, "-0");
    else
	Rprintf("  %*d | ", ndigits, close/10);
}
 
static Rboolean
stem_leaf(double *x, int n, double scale, int width, double atom)
{
    double r, c;
    int mm, mu, k, i, j, hi, lo, xi;
    int ldigits, hdigits, ndigits, pdigits;
 
    R_rsort(x,n);
 
    if(n <= 1)
	return FALSE;
 
    Rprintf("\n");
    r = atom+(x[n-1]-x[0])/scale;
    c = pow(10.,(11.-(int)(log10(r)+10)));
    mm = imin2(2, imax2(0, (int)(r*c/25)));
    k = 3*mm + 2 - 150/(n+50);
    if ((k-1)*(k-2)*(k-5)==0)
	c *= 10.;
 
    mu = 10;
    if (k*(k-4)*(k-8)==0) mu = 5;
    if ((k-1)*(k-5)*(k-6)==0) mu = 20;
 
 
    /* Find the print width of the stem. */
 
    lo = floor(x[0]  *c/mu)*mu;
    hi = floor(x[n-1]*c/mu)*mu;
    ldigits = (lo < 0) ? floor(log10(-lo))+1 : 0;
    hdigits = (hi > 0) ? floor(log10(hi))    : 0;
    ndigits = (ldigits < hdigits) ? hdigits : ldigits;
 
    /* Starting cell */
 
    if(lo < 0 && floor(x[0]*c) == lo)
	lo=lo-mu;
    hi = lo+mu;
    if(floor(x[0]*c+0.5) > hi) {
	lo = hi;
	hi = lo+mu;
    }
 
    /* Print out the info about the decimal place */
 
    pdigits= 1 - floor(log10(c)+0.5);
 
    Rprintf("  The decimal point is ");
    if(pdigits == 0)
	Rprintf("at the |\n\n");
    else
	Rprintf("%d digit(s) to the %s of the |\n\n",abs(pdigits),
		(pdigits > 0) ? "right" : "left");
    i = 0;
    do {
	if(lo < 0)
	    stem_print(hi,lo,ndigits);
	else
	    stem_print(lo,hi,ndigits);
	j = 0;
	do {
	    if(x[i] < 0)xi = x[i]*c - .5;
	    else	xi = x[i]*c + .5;
 
	    if( (hi == 0 && x[i] >= 0)||
		(lo <  0 && xi >  hi) ||
		(lo >= 0 && xi >= hi) )
		break;
 
	    j++;
	    if(j <= width-12) {
		Rprintf("%1d", abs(xi)%10);
	    }
	    i++;
	} while(i < n);
	if(j > width) {
	    Rprintf("+%d", j-width);
	}
	Rprintf("\n");
	if(i >= n)
	    break;
	hi += mu;
	lo += mu;
    } while(1);
    Rprintf("\n");
    return TRUE;
}
 
Rboolean stemleaf(double *x, int *n, double *scale, int *width, double *atom)
{
    return stem_leaf(x, *n, *scale, *width, *atom);
}

Rev 10960	Rev 11499
1	`/*`	1	`/*`
2	`* R : A Computer Language for Statistical Data Analysis`	2	`* R : A Computer Language for Statistical Data Analysis`
3	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`	3	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`
4	`* Copyright (C) 1997-2000 Robert Gentleman, Ross Ihaka and the`	4	`* Copyright (C) 1997-2000 Robert Gentleman, Ross Ihaka and the`
5	`* R Development Core Team`	5	`* R Development Core Team`
6	`*`	6	`*`
7	`* This program is free software; you can redistribute it and/or modify`	7	`* This program is free software; you can redistribute it and/or modify`
8	`* it under the terms of the GNU General Public License as published by`	8	`* it under the terms of the GNU General Public License as published by`
9	`* the Free Software Foundation; either version 2 of the License, or`	9	`* the Free Software Foundation; either version 2 of the License, or`
10	`* (at your option) any later version.`	10	`* (at your option) any later version.`
11	`*`	11	`*`
12	`* This program is distributed in the hope that it will be useful,`	12	`* This program is distributed in the hope that it will be useful,`
13	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`	13	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`
14	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`	14	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`
15	`* GNU General Public License for more details.`	15	`* GNU General Public License for more details.`
16	`*`	16	`*`
17	`* You should have received a copy of the GNU General Public License`	17	`* You should have received a copy of the GNU General Public License`
18	`* along with this program; if not, write to the Free Software`	18	`* along with this program; if not, write to the Free Software`
19	`* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA`	19	`* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA`
20	`*/`	20	`*/`
21		21
22	`#ifdef HAVE_CONFIG_H`	22	`#ifdef HAVE_CONFIG_H`
23	`#include <config.h>`	23	`#include <config.h>`
24	`#endif`	24	`#endif`
25		25
26	`#include "R_ext/Mathlib.h" /* for imin2 and imax2 */`	26	`#include <Rmath.h> /* for imin2 and imax2 */`
27	`#include "R_ext/PrtUtil.h" /* for Rprintf */`	27	`#include <R_ext/Print.h> /* for Rprintf */`
28	`#include "R_ext/Utils.h" /* for R_rsort */`	28	`#include <R_ext/Utils.h> /* for R_rsort */`
29		-
30	`#include "R_ext/Applic.h"`	29	`#include <R_ext/Applic.h>`
31		30
32	`static void stem_print(int close, int dist, int ndigits)`	31	`static void stem_print(int close, int dist, int ndigits)`
33	`{`	32	`{`
34	`if((close/10 == 0) && (dist < 0))`	33	`if((close/10 == 0) && (dist < 0))`
35	`Rprintf(" %*s \| ", ndigits, "-0");`	34	`Rprintf(" %*s \| ", ndigits, "-0");`
36	`else`	35	`else`
37	`Rprintf(" %*d \| ", ndigits, close/10);`	36	`Rprintf(" %*d \| ", ndigits, close/10);`
38	`}`	37	`}`
39		38
40	`static Rboolean`	39	`static Rboolean`
41	`stem_leaf(double *x, int n, double scale, int width, double atom)`	40	`stem_leaf(double *x, int n, double scale, int width, double atom)`
42	`{`	41	`{`
43	`double r, c;`	42	`double r, c;`
44	`int mm, mu, k, i, j, hi, lo, xi;`	43	`int mm, mu, k, i, j, hi, lo, xi;`
45	`int ldigits, hdigits, ndigits, pdigits;`	44	`int ldigits, hdigits, ndigits, pdigits;`
46		45
47	`R_rsort(x,n);`	46	`R_rsort(x,n);`
48		47
49	`if(n <= 1)`	48	`if(n <= 1)`
50	`return FALSE;`	49	`return FALSE;`
51		50
52	`Rprintf("\n");`	51	`Rprintf("\n");`
53	`r = atom+(x[n-1]-x[0])/scale;`	52	`r = atom+(x[n-1]-x[0])/scale;`
54	`c = pow(10.,(11.-(int)(log10(r)+10)));`	53	`c = pow(10.,(11.-(int)(log10(r)+10)));`
55	`mm = imin2(2, imax2(0, (int)(r*c/25)));`	54	`mm = imin2(2, imax2(0, (int)(r*c/25)));`
56	`k = 3*mm + 2 - 150/(n+50);`	55	`k = 3*mm + 2 - 150/(n+50);`
57	`if ((k-1)(k-2)(k-5)==0)`	56	`if ((k-1)(k-2)(k-5)==0)`
58	`c *= 10.;`	57	`c *= 10.;`
59		58
60	`mu = 10;`	59	`mu = 10;`
61	`if (k(k-4)(k-8)==0) mu = 5;`	60	`if (k(k-4)(k-8)==0) mu = 5;`
62	`if ((k-1)(k-5)(k-6)==0) mu = 20;`	61	`if ((k-1)(k-5)(k-6)==0) mu = 20;`
63		62
64		63
65	`/* Find the print width of the stem. */`	64	`/* Find the print width of the stem. */`
66		65
67	`lo = floor(x[0] c/mu)mu;`	66	`lo = floor(x[0] c/mu)mu;`
68	`hi = floor(x[n-1]c/mu)mu;`	67	`hi = floor(x[n-1]c/mu)mu;`
69	`ldigits = (lo < 0) ? floor(log10(-lo))+1 : 0;`	68	`ldigits = (lo < 0) ? floor(log10(-lo))+1 : 0;`
70	`hdigits = (hi > 0) ? floor(log10(hi)) : 0;`	69	`hdigits = (hi > 0) ? floor(log10(hi)) : 0;`
71	`ndigits = (ldigits < hdigits) ? hdigits : ldigits;`	70	`ndigits = (ldigits < hdigits) ? hdigits : ldigits;`
72		71
73	`/* Starting cell */`	72	`/* Starting cell */`
74		73
75	`if(lo < 0 && floor(x[0]*c) == lo)`	74	`if(lo < 0 && floor(x[0]*c) == lo)`
76	`lo=lo-mu;`	75	`lo=lo-mu;`
77	`hi = lo+mu;`	76	`hi = lo+mu;`
78	`if(floor(x[0]*c+0.5) > hi) {`	77	`if(floor(x[0]*c+0.5) > hi) {`
79	`lo = hi;`	78	`lo = hi;`
80	`hi = lo+mu;`	79	`hi = lo+mu;`
81	`}`	80	`}`
82		81
83	`/* Print out the info about the decimal place */`	82	`/* Print out the info about the decimal place */`
84		83
85	`pdigits= 1 - floor(log10(c)+0.5);`	84	`pdigits= 1 - floor(log10(c)+0.5);`
86		85
87	`Rprintf(" The decimal point is ");`	86	`Rprintf(" The decimal point is ");`
88	`if(pdigits == 0)`	87	`if(pdigits == 0)`
89	`Rprintf("at the \|\n\n");`	88	`Rprintf("at the \|\n\n");`
90	`else`	89	`else`
91	`Rprintf("%d digit(s) to the %s of the \|\n\n",abs(pdigits),`	90	`Rprintf("%d digit(s) to the %s of the \|\n\n",abs(pdigits),`
92	`(pdigits > 0) ? "right" : "left");`	91	`(pdigits > 0) ? "right" : "left");`
93	`i = 0;`	92	`i = 0;`
94	`do {`	93	`do {`
95	`if(lo < 0)`	94	`if(lo < 0)`
96	`stem_print(hi,lo,ndigits);`	95	`stem_print(hi,lo,ndigits);`
97	`else`	96	`else`
98	`stem_print(lo,hi,ndigits);`	97	`stem_print(lo,hi,ndigits);`
99	`j = 0;`	98	`j = 0;`
100	`do {`	99	`do {`
101	`if(x[i] < 0)xi = x[i]*c - .5;`	100	`if(x[i] < 0)xi = x[i]*c - .5;`
102	`else xi = x[i]*c + .5;`	101	`else xi = x[i]*c + .5;`
103		102
104	`if( (hi == 0 && x[i] >= 0)\|\|`	103	`if( (hi == 0 && x[i] >= 0)\|\|`
105	`(lo < 0 && xi > hi) \|\|`	104	`(lo < 0 && xi > hi) \|\|`
106	`(lo >= 0 && xi >= hi) )`	105	`(lo >= 0 && xi >= hi) )`
107	`break;`	106	`break;`
108		107
109	`j++;`	108	`j++;`
110	`if(j <= width-12) {`	109	`if(j <= width-12) {`
111	`Rprintf("%1d", abs(xi)%10);`	110	`Rprintf("%1d", abs(xi)%10);`
112	`}`	111	`}`
113	`i++;`	112	`i++;`
114	`} while(i < n);`	113	`} while(i < n);`
115	`if(j > width) {`	114	`if(j > width) {`
116	`Rprintf("+%d", j-width);`	115	`Rprintf("+%d", j-width);`
117	`}`	116	`}`
118	`Rprintf("\n");`	117	`Rprintf("\n");`
119	`if(i >= n)`	118	`if(i >= n)`
120	`break;`	119	`break;`
121	`hi += mu;`	120	`hi += mu;`
122	`lo += mu;`	121	`lo += mu;`
123	`} while(1);`	122	`} while(1);`
124	`Rprintf("\n");`	123	`Rprintf("\n");`
125	`return TRUE;`	124	`return TRUE;`
126	`}`	125	`}`
127		126
128	`Rboolean stemleaf(double x, int n, double scale, int width, double *atom)`	127	`Rboolean stemleaf(double x, int n, double scale, int width, double *atom)`
129	`{`	128	`{`
130	`return stem_leaf(x, n, scale, width, atom);`	129	`return stem_leaf(x, n, scale, width, atom);`
131	`}`	130	`}`

The R Project SVN R

(root)/trunk/src/appl/stem.c @ 28362 – Rev 10960 → 11499