The R Project SVN R

Rev

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

Rev 4279 Rev 4562
Line 15... Line 15...
15 
 *  You should have received a copy of the GNU General Public License
 15 
 *  You should have received a copy of the GNU General Public License
16 
 *  along with this program; if not, write to the Free Software
 16 
 *  along with this program; if not, write to the Free Software
17 
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 17 
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
18 
 */
 18 
 */
19 
 
 19 
 
20 
/*  The `` x:y ''  primitive calls do_seq(.);
 20 
/* The `` x:y ''  primitive calls do_seq(); do_seq() calls cross() if
21 
 *
 - 
 
22 
 *  do_seq(.) calls  cross(.) if both arguments are factors
 - 
 
23 
 *	      and    seq(.)   otherwise.
 21 
   both arguments are factors and seq() otherwise.
24 
 */
 22 
   */
25 
 
 23 
 
26 
#include "Defn.h"
 24 
#include "Defn.h"
27 
#include "Mathlib.h"
 25 
#include "Mathlib.h"
28 
 
 26 
 
- 
 
 27 
static SEXP
- 
 
 28 
cross(SEXP s, SEXP t)
- 
 
 29 
{
- 
 
 30 
    SEXP a, la, ls, lt;
- 
 
 31 
    int i, j, k, n, nls, nlt, vs, vt;
- 
 
 32 
 
- 
 
 33 
    n = length(s);
- 
 
 34 
    nls = nlevels(s);
- 
 
 35 
    nlt = nlevels(t);
- 
 
 36 
    PROTECT(a = allocVector(INTSXP, n));
- 
 
 37 
    for (i = 0; i < n; i++) {
- 
 
 38 
	vs = INTEGER(s)[i];
- 
 
 39 
	vt = INTEGER(t)[i];
- 
 
 40 
	if ((vs == NA_INTEGER) || (vt == NA_INTEGER))
- 
 
 41 
	    INTEGER(a)[i] = NA_INTEGER;
- 
 
 42 
	else
- 
 
 43 
	    INTEGER(a)[i] = vt + (vs - 1) * nlt;
- 
 
 44 
    }
- 
 
 45 
    ls = getAttrib(s, R_LevelsSymbol);
- 
 
 46 
    lt = getAttrib(t, R_LevelsSymbol);
- 
 
 47 
    if (!isNull(ls) && !isNull(lt)) {
- 
 
 48 
	PROTECT(la = allocVector(STRSXP, nls * nlt));
- 
 
 49 
	k = 0;
- 
 
 50 
	for (i = 0; i < nls; i++) {
- 
 
 51 
	    vs = strlen(CHAR(STRING(ls)[i]));
- 
 
 52 
	    for (j = 0; j < nlt; j++) {
- 
 
 53 
		vt = strlen(CHAR(STRING(lt)[j]));
- 
 
 54 
		STRING(la)[k] = allocString(vs + vt + 1);
- 
 
 55 
		sprintf(CHAR(STRING(la)[k]), "%s:%s",
- 
 
 56 
			CHAR(STRING(ls)[i]), CHAR(STRING(lt)[j]));
- 
 
 57 
		k++;
- 
 
 58 
	    }
- 
 
 59 
	}
- 
 
 60 
	setAttrib(a, R_LevelsSymbol, la);
- 
 
 61 
	UNPROTECT(1);
- 
 
 62 
    }
- 
 
 63 
    PROTECT(la = allocVector(STRSXP, 1));
- 
 
 64 
    STRING(la)[0] = mkChar("factor");
- 
 
 65 
    setAttrib(a, R_ClassSymbol, la);
- 
 
 66 
    UNPROTECT(2);
- 
 
 67 
    return(a);
- 
 
 68 
}
- 
 
 69 
 
- 
 
 70 
static SEXP
29 
static SEXP seq(SEXP call, SEXP s1, SEXP s2)
 71 
seq(SEXP call, SEXP s1, SEXP s2)
30 
{
 72 
{
31 
    int i, in1, n;
 73 
    int i, n, in1;
32 
    double n1, n2;
 74 
    double n1, n2;
33 
    SEXP ans;
 75 
    SEXP ans;
34 
 
 76 
 
35 
    n1 = length(s1);
 77 
    n1 = length(s1);
36 
    if( n1 > 1 )
 78 
    if( n1 > 1 )
Line 65... Line 107...
65 
}
 107 
}
66 
 
 108 
 
67 
SEXP do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
 109 
SEXP do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
68 
{
 110 
{
69 
    checkArity(op, args);
 111 
    checkArity(op, args);
- 
 
 112 
    if (isFactor(CAR(args)) && isFactor(CADR(args))) {
- 
 
 113 
	if (length(CAR(args)) != length(CADR(args)))
- 
 
 114 
	    errorcall(call, "unequal factor lengths\n");
- 
 
 115 
	return(cross(CAR(args), CADR(args)));
- 
 
 116 
    }
70 
    return seq(call, CAR(args), CADR(args));
 117 
    return seq(call, CAR(args), CADR(args));
71 
}
 118 
}
72 
 
 119 
 
73 
 
 - 
 
74 
/* It is assumed that type-checking has been done in rep */
 120 
/* It is assumed that type-checking has been done in rep */
75 
static SEXP rep2(SEXP s, SEXP ncopy)
 121 
static SEXP rep2(SEXP s, SEXP ncopy)
76 
{
 122 
{
77 
    int i, na, nc, n, j;
 123 
    int i, na, nc, n, j;
78 
    SEXP a, t, u;
 124 
    SEXP a, t, u;