The R Project SVN R

Rev

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

Rev 9385 Rev 10172
Line 55... Line 55...
55 
    PROTECT(R_fcall = LCONS(FUN, LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
 55 
    PROTECT(R_fcall = LCONS(FUN, LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
56 
 
 56 
 
57 
    PROTECT(ans = allocVector(VECSXP, n));
 57 
    PROTECT(ans = allocVector(VECSXP, n));
58 
    for(i = 0; i < n; i++) {
 58 
    for(i = 0; i < n; i++) {
59 
	INTEGER(ind)[0] = i + 1;
 59 
	INTEGER(ind)[0] = i + 1;
60 
	VECTOR(ans)[i] = eval(R_fcall, rho);
 60 
	SET_VECTOR_ELT(ans, i, eval(R_fcall, rho));
61 
    }
 61 
    }
62 
    UNPROTECT(3);
 62 
    UNPROTECT(3);
63 
    return ans;
 63 
    return ans;
64 
}
 64 
}
65 
 
 65 
 
Line 68... Line 68...
68 
   loop over */
 68 
   loop over */
69 
 
 69 
 
70 
SEXP do_apply(SEXP call, SEXP op, SEXP args, SEXP rho)
 70 
SEXP do_apply(SEXP call, SEXP op, SEXP args, SEXP rho)
71 
{
 71 
{
72 
    SEXP R_fcall, X, Xd, X1, ans, FUN;
 72 
    SEXP R_fcall, X, Xd, X1, ans, FUN;
73 
    int i, nr, nc;
 73 
    int i, j, nr, nc, inr;
74 
 
 74 
 
75 
    checkArity(op, args);
 75 
    checkArity(op, args);
76 
    X = CAR(args); args = CDR(args);
 76 
    X = CAR(args); args = CDR(args);
77 
    if(!isMatrix(X))
 77 
    if(!isMatrix(X))
78 
	errorcall(call, "First arg is not a matrix");
 78 
	errorcall(call, "First arg is not a matrix");
79 
    Xd = getAttrib(X, R_DimSymbol);
 79 
    Xd = getAttrib(X, R_DimSymbol);
80 
    nr = INTEGER(Xd)[0];
 80 
    nr = INTEGER(Xd)[0];
81 
    nc = INTEGER(Xd)[1];
 81 
    nc = INTEGER(Xd)[1];
82 
    X1 = CAR(args); args = CDR(args);
 82 
    X1 = CAR(args); args = CDR(args);
83 
    FUN = CAR(args); args = CDR(args);
 83 
    FUN = CAR(args);
84 
 
 84 
 
85 
    PROTECT(R_fcall = LCONS(FUN, LCONS(X1, LCONS(R_DotsSymbol, R_NilValue))));
 85 
    PROTECT(R_fcall = LCONS(FUN, LCONS(X1, LCONS(R_DotsSymbol, R_NilValue))));
86 
    PROTECT(ans = allocVector(VECSXP, nc));
 86 
    PROTECT(ans = allocVector(VECSXP, nc));
- 
 
 87 
    PROTECT(X1 = allocVector(TYPEOF(X), nr));
- 
 
 88 
    SETCADR(R_fcall, X1);
87 
    for(i = 0; i < nc; i++) {
 89 
    for(i = 0; i < nc; i++) {
88 
	switch(TYPEOF(X)) {
 90 
	switch(TYPEOF(X)) {
89 
	case REALSXP:
 91 
	case REALSXP:
- 
 
 92 
	    for (j = 0, inr = i*nr; j < nr; j++)
90 
	    REAL(X1) = REAL(X) + i*nr;
 93 
		REAL(X1)[j] = REAL(X)[j + inr];
91 
	    break;
 94 
	    break;
92 
	case INTSXP:
 95 
	case INTSXP:
- 
 
 96 
	    for (j = 0, inr = i*nr; j < nr; j++)
93 
	    INTEGER(X1) = INTEGER(X) + i*nr;
 97 
		INTEGER(X1)[j] = INTEGER(X)[j + inr];
94 
	    break;
 98 
	    break;
95 
	case LGLSXP:
 99 
	case LGLSXP:
- 
 
 100 
	    for (j = 0, inr = i*nr; j < nr; j++)
96 
	    LOGICAL(X1) = LOGICAL(X) + i*nr;
 101 
		LOGICAL(X1)[j] = LOGICAL(X)[j + inr];
97 
	    break;
 102 
	    break;
98 
	case CPLXSXP:
 103 
	case CPLXSXP:
- 
 
 104 
	    for (j = 0, inr = i*nr; j < nr; j++)
99 
	    COMPLEX(X1) = COMPLEX(X) + i*nr;
 105 
		COMPLEX(X1)[j] = COMPLEX(X)[j + inr];
100 
	    break;
 106 
	    break;
101 
	case STRSXP:
 107 
	case STRSXP:
- 
 
 108 
	    for (j = 0, inr = i*nr; j < nr; j++)
102 
	    STRING(X1) = STRING(X) + i*nr;
 109 
		SET_STRING_ELT(X1, j, STRING_ELT(X, j + inr));
103 
	    break;
 110 
	    break;
104 
	default:
 111 
	default:
105 
	    error("unsupported type of array in apply");
 112 
	    error("unsupported type of array in apply");
106 
	}
 113 
	}
107 
	/* careful: we have altered X1 and might have FUN = function(x) x */
 114 
	/* careful: we have altered X1 and might have FUN = function(x) x */
108 
	VECTOR(ans)[i] = duplicate(eval(R_fcall, rho));
 115 
	SET_VECTOR_ELT(ans, i, duplicate(eval(R_fcall, rho)));
109 
    }
 116 
    }
110 
    UNPROTECT(2);
 117 
    UNPROTECT(3);
111 
    return ans;
 118 
    return ans;
112 
}
 119 
}