The R Project SVN R

Rev

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

Rev 27297 Rev 28014
Line 64... Line 64...
64 
    vals = CAR(args);
 64 
    vals = CAR(args);
65 
    snr = CADR(args);
 65 
    snr = CADR(args);
66 
    snc = CADDR(args);
 66 
    snc = CADDR(args);
67 
    byrow = asInteger(CADR(CDDR(args)));
 67 
    byrow = asInteger(CADR(CDDR(args)));
68 
 
 68 
 
- 
 
 69 
    /* R wrapper does as.vector
69 
    if (isVector(vals) || isList(vals)) {
 70 
    if (isVector(vals) || isList(vals)) {
70 
	if (length(vals) < 0)
 71 
	if (length(vals) < 0)  (sic! cannot happen)
71 
	    errorcall(call, "argument has length zero");
 72 
	   errorcall(call, "argument has length zero");
72 
    }
 73 
    }
73 
    else errorcall(call, "invalid matrix element type");
 74 
    else errorcall(call, "invalid matrix element type"); */
74 
 
 75 
 
75 
    if (!isNumeric(snr) || !isNumeric(snc))
 76 
    if (!isNumeric(snr) || !isNumeric(snc))
76 
	error("non-numeric matrix extent");
 77 
	error("non-numeric matrix extent");
77 
 
 78 
 
78 
    lendat = length(vals);
 79 
    lendat = length(vals);
79 
    nr = asInteger(snr);
 80 
    nr = asInteger(snr);
80 
    nc = asInteger(snc);
 81 
    nc = asInteger(snc);
81 
 
 82 
 
- 
 
 83 
    if(lendat > 0 ) {
82 
    if (lendat > 1 && (nr * nc) % lendat != 0) {
 84 
	if (lendat > 1 && (nr * nc) % lendat != 0) {
83 
	if (((lendat > nr) && (lendat / nr) * nr != lendat) ||
 85 
	    if (((lendat > nr) && (lendat / nr) * nr != lendat) ||
84 
	    ((lendat < nr) && (nr / lendat) * lendat != nr))
 86 
		((lendat < nr) && (nr / lendat) * lendat != nr))
85 
	    warning("Replacement length not a multiple of the elements to replace in matrix(...)");
 87 
		warning("data length [%d] is not a sub-multiple or multiple of the number of rows [%d] in matrix", lendat, nr);
86 
	else if (((lendat > nc) && (lendat / nc) * nc != lendat) ||
 88 
	    else if (((lendat > nc) && (lendat / nc) * nc != lendat) ||
87 
		 ((lendat < nc) && (nc / lendat) * lendat != nc))
 89 
		     ((lendat < nc) && (nc / lendat) * lendat != nc))
88 
	    warning("Replacement length not a multiple of the elements to replace in matrix(...)");
 - 
 
89 
    }
 - 
 
90 
	else if ((lendat > 1) && (nr * nc == 0)){
 - 
 
91 
	  warning("Replacement length not a multiple of the elements to replace in matrix(...)");
 90 
		warning("data length [%d] is not a sub-multiple or multiple of the number of columns [%d] in matrix", lendat, nc);
92 
	}
 91 
	}
93 
	else if (lendat == 0 && nr * nc > 0){
 92 
	else if ((lendat > 1) && (nr * nc == 0)){
94 
	  error("No data to replace in matrix(...)");
 93 
	    warning("data length exceeds size of matrix");
95 
	}
 94 
	}
- 
 
 95 
    }
96 
 
 96 
 
97 
    PROTECT(snr = allocMatrix(TYPEOF(vals), nr, nc));
 97 
    PROTECT(snr = allocMatrix(TYPEOF(vals), nr, nc));
- 
 
 98 
    if(lendat) {
98 
    if (isVector(vals))
 99 
	if (isVector(vals))
99 
	copyMatrix(snr, vals, byrow);
 100 
	    copyMatrix(snr, vals, byrow);
100 
    else
 101 
	else
101 
	copyListMatrix(snr, vals, byrow);
 102 
	    copyListMatrix(snr, vals, byrow);
- 
 
 103 
    } else if (isVector(vals)) { /* fill with NAs */
- 
 
 104 
	int i, j;
- 
 
 105 
	switch(TYPEOF(vals)) {
- 
 
 106 
	case STRSXP:
- 
 
 107 
	    for (i = 0; i < nr; i++)
- 
 
 108 
		for (j = 0; j < nc; j++)
- 
 
 109 
		    SET_STRING_ELT(snr, i + j * nr, NA_STRING);
- 
 
 110 
	    break;
- 
 
 111 
	case LGLSXP:
- 
 
 112 
	    for (i = 0; i < nr; i++)
- 
 
 113 
		for (j = 0; j < nc; j++)
- 
 
 114 
		    LOGICAL(snr)[i + j * nr] = NA_LOGICAL;
- 
 
 115 
	    break;
- 
 
 116 
	case INTSXP:
- 
 
 117 
	    for (i = 0; i < nr; i++)
- 
 
 118 
		for (j = 0; j < nc; j++)
- 
 
 119 
		    INTEGER(snr)[i + j * nr] = NA_INTEGER;
- 
 
 120 
	    break;
- 
 
 121 
	case REALSXP:
- 
 
 122 
	    for (i = 0; i < nr; i++)
- 
 
 123 
		for (j = 0; j < nc; j++)
- 
 
 124 
		    REAL(snr)[i + j * nr] = NA_REAL;
- 
 
 125 
	    break;
- 
 
 126 
	case CPLXSXP:
- 
 
 127 
	    {
- 
 
 128 
		Rcomplex na_cmplx;
- 
 
 129 
		na_cmplx.r = NA_REAL;
- 
 
 130 
		na_cmplx.i = 0;
- 
 
 131 
		for (i = 0; i < nr; i++)
- 
 
 132 
		    for (j = 0; j < nc; j++)
- 
 
 133 
			COMPLEX(snr)[i + j * nr] = na_cmplx;
- 
 
 134 
	    }
- 
 
 135 
	    break;
- 
 
 136 
	}
- 
 
 137 
    }
102 
    UNPROTECT(1);
 138 
    UNPROTECT(1);
103 
    return snr;
 139 
    return snr;
104 
}
 140 
}
105 
 
 141 
 
106 
 
 142