The R Project SVN – R – Diff – /branches/R-exp-API/src/main/model.c

     SEXP expr, factors, terms, v, vars, vnames, assign;
     SEXP xnames, tnames, rnames;
     SEXP count, contrast, contr1, contr2, nlevs, ordered, columns, x;
     SEXP variable, var_i;
     int fik, first, i, j, k, kk, ll, n, nc, nterms, nvar;
-    int intercept, jstart, jnext, response, index;
+    int intercept, jstart, jnext, response, index, rhs_response;
-    char buf[BUFSIZE], *bufp;
+    char buf[BUFSIZE], *bufp, *addp;
     checkArity(op, args);
     /* Get the "terms" structure and extract */
     /* the intercept and response attributes. */
     v = vars;
     for (i = 0; i < nvar; i++) {
 	var_i = VECTOR(variable)[i] = VECTOR(vars)[i];
 	if (nrows(var_i) != n)
 	    errorcall(call, "variable lengths differ");
-	if (i == response - 1) {
+	/*if (i == response - 1) {
 	    LOGICAL(ordered)[0] = 0;
 	    INTEGER(nlevs)[0] = 0;
 	    INTEGER(columns)[0] = 0;
+	}
+	else */
-	else if (isOrdered(var_i)) {
+	if (isOrdered(var_i)) {
 	    LOGICAL(ordered)[i] = 1;
 	    INTEGER(nlevs)[i] = nlevels(var_i);
 	    INTEGER(columns)[i] = ncols(var_i);
+	}
 	else if (isUnordered(var_i)) {
 		VECTOR(contr2)[i] = eval(expr, rho);
+	    }
+	}
+    }
+    /* By convention, an rhs term identical to the response generates nothing
+       in the model matrix (but interactions involving the response do). */
+    rhs_response = -1;
+    if (response > 0) /* there is a response specified */
+	for (j = 0; j < nterms; j++)
+	    if (INTEGER(factors)[response - 1 + j * nvar]) {
+		for (i = 0, k = 0; i < nvar; i++)
+		    k += INTEGER(factors)[i + j * nvar] > 0;
+		if (k == 1) {
+		    rhs_response = j;
+		    break;
+		}
+	    }
     /* We now have everything needed to build the design matrix. */
     /* The first step is to compute the matrix size and to allocate it. */
     /* Note that "count" holds a count of how many columns there are */
     /* for each term in the model and "nc" gives the total column count. */
     if (intercept)
 	nc = 1;
     else
 	nc = 0;
     for (j = 0; j < nterms; j++) {
+	if (j == rhs_response) continue;
 	k = 1;
 	for (i = 0; i < nvar; i++) {
 	    if (INTEGER(factors)[i + j * nvar]) {
 		if (INTEGER(nlevs)[i]) {
 		    switch(INTEGER(factors)[i + j * nvar]) {
     /* matrix, assembling the names. */
     /* FIXME : The body within these two loops should be embedded */
     /* in its own function. */
-    /* FIXME : we need to check for buffer overflow here. */
     k = 0;
     if (intercept)
 	STRING(xnames)[k++] = mkChar("(Intercept)");
     for (j = 0; j < nterms; j++) {
+	if (j == rhs_response) continue;
 	for (kk = 0; kk < INTEGER(count)[j]; kk++) {
 	    first = 1;
 	    index = kk;
 	    bufp = &buf[0];
 	    for (i = 0; i < nvar; i++) {
+			}
 			else {
 			    x = ColumnNames(VECTOR(contr2)[i]);
 			    ll = ncols(VECTOR(contr2)[i]);
+			}
-			bufp = AppendString(bufp, CHAR(STRING(vnames)[i]));
+			addp = CHAR(STRING(vnames)[i]);
+			if(strlen(buf) + strlen(addp) < BUFSIZE)
+			    bufp = AppendString(bufp, addp);
+			else
+			    warningcall(call, "term names will be truncated");
-			if (x == R_NilValue)
+			if (x == R_NilValue) {
+			    if(strlen(buf) + 10 < BUFSIZE)
-			    bufp = AppendInteger(bufp, index % ll + 1);
+				bufp = AppendInteger(bufp, index % ll + 1);
+			    else
+				warningcall(call, "term names will be truncated");
-			else
+			} else {
+			    addp = CHAR(STRING(x)[index % ll]);
+			    if(strlen(buf) + strlen(addp) < BUFSIZE)
-			    bufp = AppendString(bufp,
+				bufp = AppendString(bufp, addp);
+			    else
-					 CHAR(STRING(x)[index % ll]));
+				warningcall(call, "term names will be truncated");
+			}
+		    }
 		    else {
 			x = ColumnNames(var_i);
 			ll = ncols(var_i);
-			bufp = AppendString(bufp, CHAR(STRING(vnames)[i]));
+			addp = CHAR(STRING(vnames)[i]);
+			if(strlen(buf) + strlen(addp) < BUFSIZE)
+			    bufp = AppendString(bufp, addp);
+			else
+			    warningcall(call, "term names will be truncated");
 			if (ll > 1) {
-			    if (x == R_NilValue)
+			    if (x == R_NilValue) {
+				if(strlen(buf) + 10 < BUFSIZE)
-				bufp = AppendInteger(bufp, index % ll + 1);
+				    bufp = AppendInteger(bufp, index % ll + 1);
+				else
+				    warningcall(call, "term names will be truncated");
-			    else
+			    } else {
+				addp = CHAR(STRING(x)[index % ll]);
+				if(strlen(buf) + strlen(addp) < BUFSIZE)
-				bufp = AppendString(bufp,
+				    bufp = AppendString(bufp, addp);
+				else
-					     CHAR(STRING(x)[index % ll]));
+				    warningcall(call, "term names will be truncated");
+			    }
+			}
+		    }
 		    index = index / ll;
+		}
+	    }
     /* b) Now loop over the model terms */
     contrast = R_NilValue;	/* -Wall */
     for (k = 0; k < nterms; k++) {
+	if (k == rhs_response) continue;
 	for (i = 0; i < nvar; i++) {
 	    if (INTEGER(columns)[i] == 0)
 		continue;
 	    var_i = VECTOR(variable)[i];
 	    fik = INTEGER(factors)[i + k * nvar];

The R Project SVN R

(root)/branches/R-exp-API/src/main/model.c @ 28362 – Rev 7002 → 7192