The R Project SVN R

Rev

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

Rev 42887 Rev 43007
Line 56... Line 56...
56 
	return R_NilValue;
 56 
	return R_NilValue;
57 
}
 57 
}
58 
 
 58 
 
59 
SEXP attribute_hidden do_matrix(SEXP call, SEXP op, SEXP args, SEXP rho)
 59 
SEXP attribute_hidden do_matrix(SEXP call, SEXP op, SEXP args, SEXP rho)
60 
{
 60 
{
61 
    SEXP vals, snr, snc;
 61 
    SEXP vals, ans, snr, snc, dimnames;
62 
    int nr, nc, byrow, lendat;
 62 
    int nr, nc, byrow, lendat;
63 
 
 63 
 
64 
    checkArity(op, args);
 64 
    checkArity(op, args);
65 
    vals = CAR(args);
 65 
    vals = CAR(args);
66 
    snr = CADR(args);
 66 
    snr = CADR(args);
67 
    snc = CADDR(args);
 67 
    snc = CADDR(args);
- 
 
 68 
    if (!isNumeric(snr) || !isNumeric(snc))
- 
 
 69 
	error(_("non-numeric matrix extent"));
68 
    byrow = asLogical(CADR(CDDR(args)));
 70 
    byrow = asLogical(CADDDR(args));
69 
    if (byrow == NA_INTEGER)
 71 
    if (byrow == NA_INTEGER)
70 
	error(_("invalid 'byrow' value"));
 72 
	error(_("invalid 'byrow' value"));
- 
 
 73 
    dimnames = CAD4R(args);
71 
 
 74 
 
72 
    if (!isNumeric(snr) || !isNumeric(snc))
 - 
 
73 
	error(_("non-numeric matrix extent"));
 - 
 
74 
 
 75 
 
75 
    lendat = length(vals);
 76 
    lendat = length(vals);
76 
    nr = asInteger(snr);
 77 
    nr = asInteger(snr);
77 
    if (nr == NA_INTEGER) /* This is < 0 */
 78 
    if (nr == NA_INTEGER) /* This is < 0 */
78 
	error(_("invalid 'nrow' value (too large or NA)"));
 79 
	error(_("invalid 'nrow' value (too large or NA)"));
Line 99... Line 100...
99 
    }
 100 
    }
100 
 
 101 
 
101 
    if ((double)nr * (double)nc > INT_MAX)
 102 
    if ((double)nr * (double)nc > INT_MAX)
102 
	error(_("too many elements specified"));
 103 
	error(_("too many elements specified"));
103 
 
 104 
 
104 
    PROTECT(snr = allocMatrix(TYPEOF(vals), nr, nc));
 105 
    PROTECT(ans = allocMatrix(TYPEOF(vals), nr, nc));
105 
    if(lendat) {
 106 
    if(lendat) {
106 
	if (isVector(vals))
 107 
	if (isVector(vals))
107 
	    copyMatrix(snr, vals, byrow);
 108 
	    copyMatrix(ans, vals, byrow);
108 
	else
 109 
	else
109 
	    copyListMatrix(snr, vals, byrow);
 110 
	    copyListMatrix(ans, vals, byrow);
110 
    } else if (isVector(vals)) { /* fill with NAs */
 111 
    } else if (isVector(vals)) { /* fill with NAs */
111 
	int i, j;
 112 
	int i, j;
112 
	switch(TYPEOF(vals)) {
 113 
	switch(TYPEOF(vals)) {
113 
	case STRSXP:
 114 
	case STRSXP:
114 
	    for (i = 0; i < nr; i++)
 115 
	    for (i = 0; i < nr; i++)
115 
		for (j = 0; j < nc; j++)
 116 
		for (j = 0; j < nc; j++)
116 
		    SET_STRING_ELT(snr, i + j * nr, NA_STRING);
 117 
		    SET_STRING_ELT(ans, i + j * nr, NA_STRING);
117 
	    break;
 118 
	    break;
118 
	case LGLSXP:
 119 
	case LGLSXP:
119 
	    for (i = 0; i < nr; i++)
 120 
	    for (i = 0; i < nr; i++)
120 
		for (j = 0; j < nc; j++)
 121 
		for (j = 0; j < nc; j++)
121 
		    LOGICAL(snr)[i + j * nr] = NA_LOGICAL;
 122 
		    LOGICAL(ans)[i + j * nr] = NA_LOGICAL;
122 
	    break;
 123 
	    break;
123 
	case INTSXP:
 124 
	case INTSXP:
124 
	    for (i = 0; i < nr; i++)
 125 
	    for (i = 0; i < nr; i++)
125 
		for (j = 0; j < nc; j++)
 126 
		for (j = 0; j < nc; j++)
126 
		    INTEGER(snr)[i + j * nr] = NA_INTEGER;
 127 
		    INTEGER(ans)[i + j * nr] = NA_INTEGER;
127 
	    break;
 128 
	    break;
128 
	case REALSXP:
 129 
	case REALSXP:
129 
	    for (i = 0; i < nr; i++)
 130 
	    for (i = 0; i < nr; i++)
130 
		for (j = 0; j < nc; j++)
 131 
		for (j = 0; j < nc; j++)
131 
		    REAL(snr)[i + j * nr] = NA_REAL;
 132 
		    REAL(ans)[i + j * nr] = NA_REAL;
132 
	    break;
 133 
	    break;
133 
	case CPLXSXP:
 134 
	case CPLXSXP:
134 
	    {
 135 
	    {
135 
		Rcomplex na_cmplx;
 136 
		Rcomplex na_cmplx;
136 
		na_cmplx.r = NA_REAL;
 137 
		na_cmplx.r = NA_REAL;
137 
		na_cmplx.i = 0;
 138 
		na_cmplx.i = 0;
138 
		for (i = 0; i < nr; i++)
 139 
		for (i = 0; i < nr; i++)
139 
		    for (j = 0; j < nc; j++)
 140 
		    for (j = 0; j < nc; j++)
140 
			COMPLEX(snr)[i + j * nr] = na_cmplx;
 141 
			COMPLEX(ans)[i + j * nr] = na_cmplx;
141 
	    }
 142 
	    }
142 
	    break;
 143 
	    break;
143 
	case RAWSXP:
 144 
	case RAWSXP:
144 
	    for (i = 0; i < nr; i++)
 145 
	    for (i = 0; i < nr; i++)
145 
		for (j = 0; j < nc; j++)
 146 
		for (j = 0; j < nc; j++)
146 
		    RAW(snr)[i + j * nr] = 0;
 147 
		    RAW(ans)[i + j * nr] = 0;
147 
	    break;
 148 
	    break;
148 
	default:
 149 
	default:
149 
	    /* don't fill with anything */
 150 
	    /* don't fill with anything */
150 
	    ;
 151 
	    ;
151 
	}
 152 
	}
152 
    }
 153 
    }
- 
 
 154 
    if(!isNull(dimnames)) ans = dimnamesgets(ans, dimnames);
153 
    UNPROTECT(1);
 155 
    UNPROTECT(1);
154 
    return snr;
 156 
    return ans;
155 
}
 157 
}
156 
 
 158 
 
157 
 
 159 
 
158 
SEXP allocMatrix(SEXPTYPE mode, int nrow, int ncol)
 160 
SEXP allocMatrix(SEXPTYPE mode, int nrow, int ncol)
159 
{
 161 
{