The R Project SVN R

Rev

Rev 73733 | Rev 82945 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 73733 Rev 77395
Line 1... Line 1...
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, 1997  Robert Gentleman and Ross Ihaka
 3 
 *  Copyright (C) 2000-2019  The R Core Team
4 
 *  Copyright (C) 2000-2016	    The R Core Team
 4 
 *  Copyright (C) 2005       The R Foundation
5 
 *  Copyright (C) 2005		    The R Foundation
 5 
 *  Copyright (C) 1995-1997  Robert Gentleman and Ross Ihaka
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.
Line 21... Line 21...
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 
/* Note: gcc -peantic may warn in several places about C99 features
26 
/* Note: gcc -pedantic may warn in several places about C99 features
27 
   as extensions.
 27 
   as extensions.
28 
   This was a very-long-standing GCC bug, http://gcc.gnu.org/PR7263
 28 
   This was a very-long-standing GCC bug, http://gcc.gnu.org/PR7263
29 
   The system <complex.h> header can work around it: some do.
 29 
   The system <complex.h> header can work around it: some do.
30 
   It should have been resolved (after a decade) in 2012.
 30 
   It should have been resolved (after a decade) in 2012.
31 
*/
 31 
*/
Line 353... Line 353...
353 
	UNPROTECT(2);
 353 
	UNPROTECT(2);
354 
    }
 354 
    }
355 
    return y;
 355 
    return y;
356 
}
 356 
}
357 
 
 357 
 
358 
/* used in format.c and printutils.c */
 358 
/* Implementing  signif(<complex>)  *and* used in format.c and printutils.c */
359 
#define MAX_DIGITS 22
 359 
#define MAX_DIGITS 22
360 
void attribute_hidden z_prec_r(Rcomplex *r, const Rcomplex *x, double digits)
 360 
void attribute_hidden z_prec_r(Rcomplex *r, const Rcomplex *x, double digits)
361 
{
 361 
{
362 
    double m = 0.0, m1, m2;
 362 
    // Implement    r <- signif(x, digits)
363 
    int dig, mag;
 - 
 
364 
 
 363 
 
365 
    r->r = x->r; r->i = x->i;
 364 
    r->r = x->r; r->i = x->i;
- 
 
 365 
    double m = 0.0,
- 
 
 366 
	m1 = fabs(x->r),
366 
    m1 = fabs(x->r); m2 = fabs(x->i);
 367 
	m2 = fabs(x->i);
367 
    if(R_FINITE(m1)) m = m1;
 368 
    if(R_FINITE(m1)) m = m1;
368 
    if(R_FINITE(m2) && m2 > m) m = m2;
 369 
    if(R_FINITE(m2) && m2 > m) m = m2;
369 
    if (m == 0.0) return;
 370 
    if (m == 0.0) return;
370 
    if (!R_FINITE(digits)) {
 371 
    if (!R_FINITE(digits)) {
371 
	if(digits > 0) return; else {r->r = r->i = 0.0; return ;}
 372 
	if(digits > 0) return; else {r->r = r->i = 0.0; return ;}
372 
    }
 373 
    }
373 
    dig = (int)floor(digits+0.5);
 374 
    int dig = (int)floor(digits+0.5);
374 
    if (dig > MAX_DIGITS) return; else if (dig < 1) dig = 1;
 375 
    if (dig > MAX_DIGITS) return; else if (dig < 1) dig = 1;
375 
    mag = (int)floor(log10(m));
 376 
    int mag = (int)floor(log10(m));
376 
    dig = dig - mag - 1;
 377 
    dig = dig - mag - 1;
377 
    if (dig > 306) {
 378 
    if (dig > 306) {
378 
	double pow10 = 1.0e4;
 379 
	double pow10 = 1.0e4;
379 
	digits = (double)(dig - 4);
 380 
	digits = (double)(dig - 4);
380 
	r->r = fround(pow10 * x->r, digits)/pow10;
 381 
	r->r = fround(pow10 * x->r, digits)/pow10;
Line 614... Line 615...
614 
    const Rcomplex *px = COMPLEX_RO(x);
 615 
    const Rcomplex *px = COMPLEX_RO(x);
615 
    Rcomplex *py = COMPLEX(y);
 616 
    Rcomplex *py = COMPLEX(y);
616 
 
 617 
 
617 
    switch (PRIMVAL(op)) {
 618 
    switch (PRIMVAL(op)) {
618 
    case 10003: naflag = cmath1(clog, px, py, n); break;
 619 
    case 10003: naflag = cmath1(clog, px, py, n); break;
- 
 
 620 
	// 1: floor
- 
 
 621 
	// 2: ceil[ing]
619 
    case 3: naflag = cmath1(csqrt, px, py, n); break;
 622 
    case 3: naflag = cmath1(csqrt, px, py, n); break;
- 
 
 623 
	// 4: sign
620 
    case 10: naflag = cmath1(cexp, px, py, n); break;
 624 
    case 10: naflag = cmath1(cexp, px, py, n); break;
- 
 
 625 
	// 11: expm1
- 
 
 626 
	// 12: log1p
621 
    case 20: naflag = cmath1(ccos, px, py, n); break;
 627 
    case 20: naflag = cmath1(ccos, px, py, n); break;
622 
    case 21: naflag = cmath1(csin, px, py, n); break;
 628 
    case 21: naflag = cmath1(csin, px, py, n); break;
623 
    case 22: naflag = cmath1(z_tan, px, py, n); break;
 629 
    case 22: naflag = cmath1(z_tan, px, py, n); break;
624 
    case 23: naflag = cmath1(z_acos, px, py, n); break;
 630 
    case 23: naflag = cmath1(z_acos, px, py, n); break;
625 
    case 24: naflag = cmath1(z_asin, px, py, n); break;
 631 
    case 24: naflag = cmath1(z_asin, px, py, n); break;
626 
    case 25: naflag = cmath1(z_atan, px, py, n); break;
 632 
    case 25: naflag = cmath1(z_atan, px, py, n); break;
- 
 
 633 
 
627 
    case 30: naflag = cmath1(ccosh, px, py, n); break;
 634 
    case 30: naflag = cmath1(ccosh, px, py, n); break;
628 
    case 31: naflag = cmath1(csinh, px, py, n); break;
 635 
    case 31: naflag = cmath1(csinh, px, py, n); break;
629 
    case 32: naflag = cmath1(ctanh, px, py, n); break;
 636 
    case 32: naflag = cmath1(ctanh, px, py, n); break;
630 
    case 33: naflag = cmath1(z_acosh, px, py, n); break;
 637 
    case 33: naflag = cmath1(z_acosh, px, py, n); break;
631 
    case 34: naflag = cmath1(z_asinh, px, py, n); break;
 638 
    case 34: naflag = cmath1(z_asinh, px, py, n); break;