The R Project SVN R

Rev

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

Rev 68344 Rev 68663
Line 26... Line 26...
26 
#include <Defn.h>
 26 
#include <Defn.h>
27 
#include <Internal.h>
 27 
#include <Internal.h>
28 
#include <Rmath.h>
 28 
#include <Rmath.h>
29 
#include <R_ext/RS.h>     /* for Calloc/Free */
 29 
#include <R_ext/RS.h>     /* for Calloc/Free */
30 
#include <R_ext/Applic.h> /* for dgemm */
 30 
#include <R_ext/Applic.h> /* for dgemm */
- 
 
 31 
#include <R_ext/Itermacros.h>
- 
 
 32 
 
- 
 
 33 
#include "duplicate.h"
31 
 
 34 
 
32 
/* "GetRowNames" and "GetColNames" are utility routines which
 35 
/* "GetRowNames" and "GetColNames" are utility routines which
33 
 * locate and return the row names and column names from the
 36 
 * locate and return the row names and column names from the
34 
 * dimnames attribute of a matrix.  They are useful because
 37 
 * dimnames attribute of a matrix.  They are useful because
35 
 * old versions of R used pair-based lists for dimnames
 38 
 * old versions of R used pair-based lists for dimnames
Line 1562... Line 1565...
1562 
 
 1565 
 
1563 
    PROTECT(ans = allocVector(TYPEOF(vals), nans));
 1566 
    PROTECT(ans = allocVector(TYPEOF(vals), nans));
1564 
    switch(TYPEOF(vals)) {
 1567 
    switch(TYPEOF(vals)) {
1565 
    case LGLSXP:
 1568 
    case LGLSXP:
1566 
	if (nans && lendat)
 1569 
	if (nans && lendat)
1567 
	    for (i = 0; i < nans; i++)
 1570 
	    xcopyLogicalWithRecycle(LOGICAL(ans), LOGICAL(vals), 0, nans,
1568 
		LOGICAL(ans)[i] = LOGICAL(vals)[i % lendat];
 1571 
				    lendat);
1569 
	else
 1572 
	else
1570 
	    for (i = 0; i < nans; i++) LOGICAL(ans)[i] = NA_LOGICAL;
 1573 
	    for (i = 0; i < nans; i++) LOGICAL(ans)[i] = NA_LOGICAL;
1571 
	break;
 1574 
	break;
1572 
    case INTSXP:
 1575 
    case INTSXP:
1573 
	if (nans && lendat)
 1576 
	if (nans && lendat)
1574 
	    for (i = 0; i < nans; i++)
 1577 
	    xcopyIntegerWithRecycle(INTEGER(ans), INTEGER(vals), 0, nans,
1575 
		INTEGER(ans)[i] = INTEGER(vals)[i % lendat];
 1578 
				    lendat);
1576 
	else
 1579 
	else
1577 
	    for (i = 0; i < nans; i++) INTEGER(ans)[i] = NA_INTEGER;
 1580 
	    for (i = 0; i < nans; i++) INTEGER(ans)[i] = NA_INTEGER;
1578 
	break;
 1581 
	break;
1579 
    case REALSXP:
 1582 
    case REALSXP:
1580 
	if (nans && lendat)
 1583 
	if (nans && lendat)
1581 
	    for (i = 0; i < nans; i++) REAL(ans)[i] = REAL(vals)[i % lendat];
 1584 
	    xcopyRealWithRecycle(REAL(ans), REAL(vals), 0, nans, lendat);
1582 
	else
 1585 
	else
1583 
	    for (i = 0; i < nans; i++) REAL(ans)[i] = NA_REAL;
 1586 
	    for (i = 0; i < nans; i++) REAL(ans)[i] = NA_REAL;
1584 
	break;
 1587 
	break;
1585 
    case CPLXSXP:
 1588 
    case CPLXSXP:
1586 
	if (nans && lendat)
 1589 
	if (nans && lendat)
1587 
	    for (i = 0; i < nans; i++)
 1590 
	    xcopyComplexWithRecycle(COMPLEX(ans), COMPLEX(vals), 0, nans,
1588 
		COMPLEX(ans)[i] = COMPLEX(vals)[i % lendat];
 1591 
				    lendat);
1589 
	else {
 1592 
	else {
1590 
	    Rcomplex na_cmplx;
 1593 
	    Rcomplex na_cmplx;
1591 
	    na_cmplx.r = NA_REAL;
 1594 
	    na_cmplx.r = NA_REAL;
1592 
	    na_cmplx.i = 0;
 1595 
	    na_cmplx.i = 0;
1593 
	    for (i = 0; i < nans; i++) COMPLEX(ans)[i] = na_cmplx;
 1596 
	    for (i = 0; i < nans; i++) COMPLEX(ans)[i] = na_cmplx;
1594 
	}
 1597 
	}
1595 
	break;
 1598 
	break;
1596 
    case RAWSXP:
 1599 
    case RAWSXP:
1597 
	if (nans && lendat)
 1600 
	if (nans && lendat)
1598 
	    for (i = 0; i < nans; i++) RAW(ans)[i] = RAW(vals)[i % lendat];
 1601 
	    xcopyRawWithRecycle(RAW(ans), RAW(vals), 0, nans, lendat);
1599 
	else
 1602 
	else
1600 
	    for (i = 0; i < nans; i++) RAW(ans)[i] = 0;
 1603 
	    for (i = 0; i < nans; i++) RAW(ans)[i] = 0;
1601 
	break;
 1604 
	break;
1602 
    /* Rest are already initialized */
 1605 
    /* Rest are already initialized */
1603 
    case STRSXP:
 1606 
    case STRSXP:
1604 
	if (nans && lendat)
 1607 
	if (nans && lendat)
1605 
	    for (i = 0; i < nans; i++)
 - 
 
1606 
		SET_STRING_ELT(ans, i, STRING_ELT(vals, i % lendat));
 1608 
	    xcopyStringWithRecycle(ans, vals, 0, nans, lendat);
1607 
	break;
 1609 
	break;
1608 
    case VECSXP:
 1610 
    case VECSXP:
1609 
    case EXPRSXP:
 1611 
    case EXPRSXP:
1610 
#ifdef SWITCH_TO_REFCNT
 1612 
#ifdef SWITCH_TO_REFCNT
1611 
	if (nans && lendat)
 1613 
	if (nans && lendat)
1612 
	    for (i = 0; i < nans; i++)
 - 
 
1613 
		SET_VECTOR_ELT(ans, i, VECTOR_ELT(vals, i % lendat));
 1614 
	    xcopyVectorWithRecycle(ans, vals, 0, nans, lendat);
1614 
#else
 1615 
#else
1615 
	if (nans && lendat) {
 1616 
	if (nans && lendat) {
1616 
	    /* Need to guard against possible sharing of values under
 1617 
	    /* Need to guard against possible sharing of values under
1617 
	       NAMED.  This is not needed with reference
 1618 
	       NAMED.  This is not needed with reference
1618 
	       coutning. (PR#15919) */
 1619 
	       coutning. (PR#15919) */
Line 1675... Line 1676...
1675 
       int nx = LENGTH(x);
 1676 
       int nx = LENGTH(x);
1676 
       R_xlen_t NR = nr;
 1677 
       R_xlen_t NR = nr;
1677 
       Rcomplex *rx = COMPLEX(x), *ra = COMPLEX(ans), zero;
 1678 
       Rcomplex *rx = COMPLEX(x), *ra = COMPLEX(ans), zero;
1678 
       zero.r = zero.i = 0.0;
 1679 
       zero.r = zero.i = 0.0;
1679 
       for (R_xlen_t i = 0; i < NR*nc; i++) ra[i] = zero;
 1680 
       for (R_xlen_t i = 0; i < NR*nc; i++) ra[i] = zero;
- 
 
 1681 
       R_xlen_t i, i1;
- 
 
 1682 
       MOD_ITERATE1(mn, nx, i, i1, {
1680 
       for (int j = 0; j < mn; j++) ra[j * (NR+1)] = rx[j % nx];
 1683 
	   ra[i * (NR+1)] = rx[i1];
- 
 
 1684 
       });
1681 
  } else {
 1685 
  } else {
1682 
       if(TYPEOF(x) != REALSXP) {
 1686 
       if(TYPEOF(x) != REALSXP) {
1683 
	   PROTECT(x = coerceVector(x, REALSXP));
 1687 
	   PROTECT(x = coerceVector(x, REALSXP));
1684 
	   nprotect++;
 1688 
	   nprotect++;
1685 
       }
 1689 
       }
1686 
       PROTECT(ans = allocMatrix(REALSXP, nr, nc));
 1690 
       PROTECT(ans = allocMatrix(REALSXP, nr, nc));
1687 
       int nx = LENGTH(x);
 1691 
       int nx = LENGTH(x);
1688 
       R_xlen_t NR = nr;
 1692 
       R_xlen_t NR = nr;
1689 
       double *rx = REAL(x), *ra = REAL(ans);
 1693 
       double *rx = REAL(x), *ra = REAL(ans);
1690 
       for (R_xlen_t i = 0; i < NR*nc; i++) ra[i] = 0.0;
 1694 
       for (R_xlen_t i = 0; i < NR*nc; i++) ra[i] = 0.0;
- 
 
 1695 
       R_xlen_t i, i1;
- 
 
 1696 
       MOD_ITERATE1(mn, nx, i, i1, {
1691 
       for (int j = 0; j < mn; j++) ra[j * (NR+1)] = rx[j % nx];
 1697 
	   ra[i * (NR+1)] = rx[i1];
- 
 
 1698 
       });
1692 
   }
 1699 
   }
1693 
   UNPROTECT(nprotect);
 1700 
   UNPROTECT(nprotect);
1694 
   return ans;
 1701 
   return ans;
1695 
}
 1702 
}
1696 
 
 1703