The R Project SVN R

Rev

Details | Last modification | View Log | RSS feed

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