The R Project SVN R

Rev

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

Rev 51316 Rev 51657
Line 1252... Line 1252...
1252 
    }
 1252 
    }
1253 
    FINISH_Math2;
 1253 
    FINISH_Math2;
1254 
    return sy;
 1254 
    return sy;
1255 
} /* math2_2() */
 1255 
} /* math2_2() */
1256 
 
 1256 
 
- 
 
 1257 
static SEXP math2B(SEXP sa, SEXP sb, double (*f)(double, double, double *),
- 
 
 1258 
		   SEXP lcall)
- 
 
 1259 
{
- 
 
 1260 
    SEXP sy;
- 
 
 1261 
    int i, ia, ib, n, na, nb;
- 
 
 1262 
    double ai, bi, *a, *b, *y;
- 
 
 1263 
    int naflag;
- 
 
 1264 
    double amax, *work;
- 
 
 1265 
    long nw;
- 
 
 1266 
 
- 
 
 1267 
    if (!isNumeric(sa) || !isNumeric(sb))
- 
 
 1268 
	errorcall(lcall, R_MSG_NONNUM_MATH);
- 
 
 1269 
 
- 
 
 1270 
    /* for 0-length a we want the attributes of a, not those of b
- 
 
 1271 
       as no recycling will occur */
- 
 
 1272 
    SETUP_Math2;
- 
 
 1273 
 
- 
 
 1274 
#ifdef R_MEMORY_PROFILING
- 
 
 1275 
    if (RTRACE(sa) || RTRACE(sb)){
- 
 
 1276 
       if (RTRACE(sa) && RTRACE(sb)){
- 
 
 1277 
	  if (na>nb)
- 
 
 1278 
	      memtrace_report(sa, sy);
- 
 
 1279 
	  else
- 
 
 1280 
	      memtrace_report(sb, sy);
- 
 
 1281 
       } else if (RTRACE(sa))
- 
 
 1282 
	   memtrace_report(sa, sy);
- 
 
 1283 
       else /* only s2 */
- 
 
 1284 
	   memtrace_report(sb, sy);
- 
 
 1285 
       SET_RTRACE(sy, 1);
- 
 
 1286 
    }
- 
 
 1287 
#endif
- 
 
 1288 
 
- 
 
 1289 
    /* allocate work array for BesselJ, BesselY large enough for all
- 
 
 1290 
       arguments */
- 
 
 1291 
    amax = 0.0;
- 
 
 1292 
    for (i = 0; i < nb; i++) {
- 
 
 1293 
	double av = b[i] < 0 ? -b[i] : b[i];
- 
 
 1294 
	if (av > amax) amax = av;
- 
 
 1295 
    }
- 
 
 1296 
    nw = 1 + (long)floor(amax);
- 
 
 1297 
    work = (double *) R_alloc(nw, sizeof(double));
- 
 
 1298 
 
- 
 
 1299 
    mod_iterate(na, nb, ia, ib) {
- 
 
 1300 
	ai = a[ia];
- 
 
 1301 
	bi = b[ib];
- 
 
 1302 
	if_NA_Math2_set(y[i], ai, bi)
- 
 
 1303 
	else {
- 
 
 1304 
	    y[i] = f(ai, bi, work);
- 
 
 1305 
	    if (ISNAN(y[i])) naflag = 1;
- 
 
 1306 
	}
- 
 
 1307 
    }
- 
 
 1308 
 
- 
 
 1309 
 
- 
 
 1310 
    FINISH_Math2;
- 
 
 1311 
 
- 
 
 1312 
    return sy;
- 
 
 1313 
} /* math2B() */
- 
 
 1314 
 
1257 
#define Math2(A, FUN)	  math2(CAR(A), CADR(A), FUN, call);
 1315 
#define Math2(A, FUN)	  math2(CAR(A), CADR(A), FUN, call);
1258 
#define Math2_1(A, FUN)	math2_1(CAR(A), CADR(A), CADDR(A), FUN, call);
 1316 
#define Math2_1(A, FUN)	math2_1(CAR(A), CADR(A), CADDR(A), FUN, call);
1259 
#define Math2_2(A, FUN) math2_2(CAR(A), CADR(A), CADDR(A), CADDDR(A), FUN, call)
 1317 
#define Math2_2(A, FUN) math2_2(CAR(A), CADR(A), CADDR(A), CADDDR(A), FUN, call)
- 
 
 1318 
#define Math2B(A, FUN)	  math2B(CAR(A), CADR(A), FUN, call);
1260 
 
 1319 
 
1261 
SEXP attribute_hidden do_math2(SEXP call, SEXP op, SEXP args, SEXP env)
 1320 
SEXP attribute_hidden do_math2(SEXP call, SEXP op, SEXP args, SEXP env)
1262 
{
 1321 
{
1263 
    checkArity(op, args);
 1322 
    checkArity(op, args);
1264 
 
 1323 
 
Line 1300... Line 1359...
1300 
 
 1359 
 
1301 
    case 21: return Math2_1(args, dsignrank);
 1360 
    case 21: return Math2_1(args, dsignrank);
1302 
    case 22: return Math2_2(args, psignrank);
 1361 
    case 22: return Math2_2(args, psignrank);
1303 
    case 23: return Math2_2(args, qsignrank);
 1362 
    case 23: return Math2_2(args, qsignrank);
1304 
 
 1363 
 
1305 
    case 24: return Math2(args, bessel_j);
 1364 
    case 24: return Math2B(args, bessel_j_ex);
1306 
    case 25: return Math2(args, bessel_y);
 1365 
    case 25: return Math2B(args, bessel_y_ex);
1307 
    case 26: return Math2(args, psigamma);
 1366 
    case 26: return Math2(args, psigamma);
1308 
 
 1367 
 
1309 
    default:
 1368 
    default:
1310 
	errorcall(call,
 1369 
	errorcall(call,
1311 
		  _("unimplemented real function of %d numeric arguments"), 2);
 1370 
		  _("unimplemented real function of %d numeric arguments"), 2);
Line 1608... Line 1667...
1608 
 
 1667 
 
1609 
    FINISH_Math3;
 1668 
    FINISH_Math3;
1610 
    return sy;
 1669 
    return sy;
1611 
} /* math3_2 */
 1670 
} /* math3_2 */
1612 
 
 1671 
 
- 
 
 1672 
static SEXP math3B(SEXP sa, SEXP sb, SEXP sc,
- 
 
 1673 
		   double (*f)(double, double, double, double *), SEXP lcall)
- 
 
 1674 
{
- 
 
 1675 
    SEXP sy;
- 
 
 1676 
    int i, ia, ib, ic, n, na, nb, nc;
- 
 
 1677 
    double ai, bi, ci, *a, *b, *c, *y;
- 
 
 1678 
    int naflag;
- 
 
 1679 
    double amax, *work;
- 
 
 1680 
    long nw;
- 
 
 1681 
 
- 
 
 1682 
    SETUP_Math3;
- 
 
 1683 
 
- 
 
 1684 
#ifdef R_MEMORY_PROFILING
- 
 
 1685 
    if (RTRACE(sa) || RTRACE(sb) || RTRACE(sc)){
- 
 
 1686 
       if (RTRACE(sa))
- 
 
 1687 
	  memtrace_report(sa,sy);
- 
 
 1688 
       else if (RTRACE(sb))
- 
 
 1689 
	  memtrace_report(sb, sy);
- 
 
 1690 
       else if (RTRACE(sc))
- 
 
 1691 
	  memtrace_report(sc,sy);
- 
 
 1692 
       SET_RTRACE(sy, 1);
- 
 
 1693 
    }
- 
 
 1694 
#endif
- 
 
 1695 
 
- 
 
 1696 
    /* allocate work array for BesselI, BesselK large enough for all
- 
 
 1697 
       arguments */
- 
 
 1698 
    amax = 0.0;
- 
 
 1699 
    for (i = 0; i < nb; i++) {
- 
 
 1700 
	double av = b[i] < 0 ? -b[i] : b[i];
- 
 
 1701 
	if (av > amax) amax = av;
- 
 
 1702 
    }
- 
 
 1703 
    nw = 1 + (long)floor(amax);
- 
 
 1704 
    work = (double *) R_alloc(nw, sizeof(double));
- 
 
 1705 
 
- 
 
 1706 
    mod_iterate3 (na, nb, nc, ia, ib, ic) {
- 
 
 1707 
	ai = a[ia];
- 
 
 1708 
	bi = b[ib];
- 
 
 1709 
	ci = c[ic];
- 
 
 1710 
	if_NA_Math3_set(y[i], ai,bi,ci)
- 
 
 1711 
	else {
- 
 
 1712 
	    y[i] = f(ai, bi, ci, work);
- 
 
 1713 
	    if (ISNAN(y[i])) naflag = 1;
- 
 
 1714 
	}
- 
 
 1715 
    }
- 
 
 1716 
 
- 
 
 1717 
    FINISH_Math3;
- 
 
 1718 
 
- 
 
 1719 
    return sy;
- 
 
 1720 
} /* math3B */
- 
 
 1721 
 
1613 
#define Math3(A, FUN)   math3  (CAR(A), CADR(A), CADDR(A), FUN, call);
 1722 
#define Math3(A, FUN)   math3  (CAR(A), CADR(A), CADDR(A), FUN, call);
1614 
#define Math3_1(A, FUN)	math3_1(CAR(A), CADR(A), CADDR(A), CADDDR(A), FUN, call);
 1723 
#define Math3_1(A, FUN)	math3_1(CAR(A), CADR(A), CADDR(A), CADDDR(A), FUN, call);
1615 
#define Math3_2(A, FUN) math3_2(CAR(A), CADR(A), CADDR(A), CADDDR(A), CAD4R(A), FUN, call)
 1724 
#define Math3_2(A, FUN) math3_2(CAR(A), CADR(A), CADDR(A), CADDDR(A), CAD4R(A), FUN, call)
- 
 
 1725 
#define Math3B(A, FUN)  math3B (CAR(A), CADR(A), CADDR(A), FUN, call);
1616 
 
 1726 
 
1617 
SEXP attribute_hidden do_math3(SEXP call, SEXP op, SEXP args, SEXP env)
 1727 
SEXP attribute_hidden do_math3(SEXP call, SEXP op, SEXP args, SEXP env)
1618 
{
 1728 
{
1619 
    checkArity(op, args);
 1729 
    checkArity(op, args);
1620 
 
 1730 
 
Line 1674... Line 1784...
1674 
 
 1784 
 
1675 
    case 40:  return Math3_1(args, dwilcox);
 1785 
    case 40:  return Math3_1(args, dwilcox);
1676 
    case 41:  return Math3_2(args, pwilcox);
 1786 
    case 41:  return Math3_2(args, pwilcox);
1677 
    case 42:  return Math3_2(args, qwilcox);
 1787 
    case 42:  return Math3_2(args, qwilcox);
1678 
 
 1788 
 
1679 
    case 43:  return Math3(args, bessel_i);
 1789 
    case 43:  return Math3B(args, bessel_i_ex);
1680 
    case 44:  return Math3(args, bessel_k);
 1790 
    case 44:  return Math3B(args, bessel_k_ex);
1681 
 
 1791 
 
1682 
    case 45:  return Math3_1(args, dnbinom_mu);
 1792 
    case 45:  return Math3_1(args, dnbinom_mu);
1683 
    case 46:  return Math3_2(args, pnbinom_mu);
 1793 
    case 46:  return Math3_2(args, pnbinom_mu);
1684 
    case 47:  return Math3_2(args, qnbinom_mu);
 1794 
    case 47:  return Math3_2(args, qnbinom_mu);
1685 
 
 1795