The R Project SVN R

Rev

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

Rev 61566 Rev 61696
Line 130... Line 130...
130 
	else if ((lendat > 1) && (nrc == 0)){
 130 
	else if ((lendat > 1) && (nrc == 0)){
131 
	    warning(_("data length exceeds size of matrix"));
 131 
	    warning(_("data length exceeds size of matrix"));
132 
	}
 132 
	}
133 
    }
 133 
    }
134 
 
 134 
 
135 
 #ifndef LONG_VECTOR_SUPPORT
 135 
#ifndef LONG_VECTOR_SUPPORT
136 
   if ((double)nr * (double)nc > INT_MAX)
 136 
    if ((double)nr * (double)nc > INT_MAX)
137 
	error(_("too many elements specified"));
 137 
	error(_("too many elements specified"));
138 
#endif
 138 
#endif
139 
 
 139 
 
140 
    PROTECT(ans = allocMatrix(TYPEOF(vals), nr, nc));
 140 
    PROTECT(ans = allocMatrix(TYPEOF(vals), nr, nc));
141 
    if(lendat) {
 141 
    if(lendat) {
Line 1090... Line 1090...
1090 
 
 1090 
 
1091 
    int *pp = (int *) R_alloc((size_t) n, sizeof(int));
 1091 
    int *pp = (int *) R_alloc((size_t) n, sizeof(int));
1092 
    perm = CADR(args);
 1092 
    perm = CADR(args);
1093 
    if (length(perm) == 0) {
 1093 
    if (length(perm) == 0) {
1094 
	for (i = 0; i < n; i++) pp[i] = n-1-i;
 1094 
	for (i = 0; i < n; i++) pp[i] = n-1-i;
1095 
    } else if (isString(perm)) {
 - 
 
1096 
	SEXP dna = getAttrib(a, R_DimNamesSymbol);
 - 
 
1097 
	if (isNull(dna))
 - 
 
1098 
	    error(_("'a' does not have named dimnames"));
 - 
 
1099 
	SEXP dnna = getAttrib(dna, R_NamesSymbol);
 - 
 
1100 
	if (isNull(dnna))
 - 
 
1101 
	    error(_("'a' does not have named dimnames"));
 - 
 
1102 
	for (i = 0; i < n; i++) {
 - 
 
1103 
	    const char *this = translateChar(STRING_ELT(perm, i));
 - 
 
1104 
	    for (j = 0; j < n; j++)
 - 
 
1105 
		if (streql(translateChar(STRING_ELT(dnna, j)),
 - 
 
1106 
			   this)) {pp[i] = j; break;}
 - 
 
1107 
	    if (j >= n)
 - 
 
1108 
		error(_("'perm[%d]' does not match a dimension name"), i+1);
 - 
 
1109 
	}
 - 
 
1110 
    } else {
 1095 
    } else {
- 
 
 1096 
	if (LENGTH(perm) != n)
1111 
	PROTECT(perm = coerceVector(perm, INTSXP));
 1097 
	    error(_("'perm' is of wrong length %d (!= %d)"),
1112 
	if (LENGTH(perm) == n) {
 1098 
		  LENGTH(perm), n);
- 
 
 1099 
	if (isString(perm)) {
- 
 
 1100 
	    SEXP dna = getAttrib(a, R_DimNamesSymbol);
- 
 
 1101 
	    if (isNull(dna))
- 
 
 1102 
		error(_("'a' does not have named dimnames"));
- 
 
 1103 
	    SEXP dnna = getAttrib(dna, R_NamesSymbol);
- 
 
 1104 
	    if (isNull(dnna))
- 
 
 1105 
		error(_("'a' does not have named dimnames"));
- 
 
 1106 
	    for (i = 0; i < n; i++) {
- 
 
 1107 
		const char *this = translateChar(STRING_ELT(perm, i));
- 
 
 1108 
		for (j = 0; j < n; j++)
- 
 
 1109 
		    if (streql(translateChar(STRING_ELT(dnna, j)),
- 
 
 1110 
			       this)) {pp[i] = j; break;}
- 
 
 1111 
		if (j >= n)
- 
 
 1112 
		    error(_("'perm[%d]' does not match a dimension name"), i+1);
- 
 
 1113 
	    }
- 
 
 1114 
	} else {
- 
 
 1115 
	    PROTECT(perm = coerceVector(perm, INTSXP));
1113 
	    for (i = 0; i < n; i++) pp[i] = INTEGER(perm)[i] - 1;
 1116 
	    for (i = 0; i < n; i++) pp[i] = INTEGER(perm)[i] - 1;
1114 
	    UNPROTECT(1);
 1117 
	    UNPROTECT(1);
1115 
	} else error(_("'perm' is of wrong length"));
 - 
 
- 
 
 1118 
	}
1116 
    }
 1119 
    }
1117 
 
 1120 
 
1118 
    R_xlen_t *iip = (R_xlen_t *) R_alloc((size_t) n, sizeof(R_xlen_t));
 1121 
    R_xlen_t *iip = (R_xlen_t *) R_alloc((size_t) n, sizeof(R_xlen_t));
1119 
    for (i = 0; i < n; iip[i++] = 0);
 1122 
    for (i = 0; i < n; iip[i++] = 0);
1120 
    for (i = 0; i < n; i++)
 1123 
    for (i = 0; i < n; i++)
Line 1372... Line 1375...
1372 
	    }
 1375 
	    }
1373 
	}
 1376 
	}
1374 
	if (OP == 3) {
 1377 
	if (OP == 3) {
1375 
	    if (keepNA)
 1378 
	    if (keepNA)
1376 
		for (int i = 0; i < n; i++) rans[i] /= p;
 1379 
		for (int i = 0; i < n; i++) rans[i] /= p;
1377 
	    else
1380 
	    else
1378 
		for (int i = 0; i < n; i++) rans[i] /= Cnt[i];
 1381 
		for (int i = 0; i < n; i++) rans[i] /= Cnt[i];
1379 
	}
 1382 
	}
1380 
	for (int i = 0; i < n; i++) REAL(ans)[i] = (double) rans[i];
 1383 
	for (int i = 0; i < n; i++) REAL(ans)[i] = (double) rans[i];
1381 
 
 1384 
 
1382 
	if (!keepNA && OP == 3) Free(Cnt);
 1385 
	if (!keepNA && OP == 3) Free(Cnt);
Line 1391... Line 1394...
1391 
{
 1394 
{
1392 
    data <- as.vector(data)
 1395 
    data <- as.vector(data)
1393 
    dim <- as.integer(dim)
 1396 
    dim <- as.integer(dim)
1394 
    vl <- prod(dim)
 1397 
    vl <- prod(dim)
1395 
    if (length(data) != vl) {
 1398 
    if (length(data) != vl) {
1396 
        if (vl > .Machine$integer.max)
1399 
        if (vl > .Machine$integer.max)
1397 
            stop("'dim' specifies too large an array")
 1400 
            stop("'dim' specifies too large an array")
1398 
        data <- rep(data, length.out = vl)
 1401 
        data <- rep(data, length.out = vl)
1399 
    }
 1402 
    }
1400 
    if (length(dim))
1403 
    if (length(dim))
1401 
        dim(data) <- dim
 1404 
        dim(data) <- dim
1402 
    if (is.list(dimnames) && length(dimnames))
1405 
    if (is.list(dimnames) && length(dimnames))
1403 
        dimnames(data) <- dimnames
 1406 
        dimnames(data) <- dimnames
1404 
    data
 1407 
    data
1405 
}
 1408 
}
1406 
*/
 1409 
*/
1407 
 
 1410 
 
Line 1501... Line 1504...
1501 
    if (TYPEOF(dimnames) == VECSXP && LENGTH(dimnames)) {
 1504 
    if (TYPEOF(dimnames) == VECSXP && LENGTH(dimnames)) {
1502 
	PROTECT(ans);
 1505 
	PROTECT(ans);
1503 
	ans = dimnamesgets(ans, dimnames);
 1506 
	ans = dimnamesgets(ans, dimnames);
1504 
	UNPROTECT(1);
 1507 
	UNPROTECT(1);
1505 
    }
 1508 
    }
1506
1509 
 
1507 
    UNPROTECT(2);
 1510 
    UNPROTECT(2);
1508 
    return ans;
 1511 
    return ans;
1509 
}
 1512 
}
1510 
 
 1513 
 
1511 
SEXP attribute_hidden do_diag(SEXP call, SEXP op, SEXP args, SEXP rho)
 1514 
SEXP attribute_hidden do_diag(SEXP call, SEXP op, SEXP args, SEXP rho)
Line 1525... Line 1528...
1525 
    nc = asInteger(snc);
 1528 
    nc = asInteger(snc);
1526 
    if (nc == NA_INTEGER)
 1529 
    if (nc == NA_INTEGER)
1527 
	error(_("invalid 'ncol' value (too large or NA)"));
 1530 
	error(_("invalid 'ncol' value (too large or NA)"));
1528 
    if (nc < 0)
 1531 
    if (nc < 0)
1529 
	error(_("invalid 'ncol' value (< 0)"));
 1532 
	error(_("invalid 'ncol' value (< 0)"));
1530 
    int mn = (nr < nc) ? nr : nc;
1533 
    int mn = (nr < nc) ? nr : nc;
1531 
    if (mn > 0 && LENGTH(x) == 0)
 1534 
    if (mn > 0 && LENGTH(x) == 0)
1532 
	error(_("'x' must have positive length"));
 1535 
	error(_("'x' must have positive length"));
1533 
 
 1536 
 
1534 
 #ifndef LONG_VECTOR_SUPPORT
 1537 
 #ifndef LONG_VECTOR_SUPPORT
1535 
   if ((double)nr * (double)nc > INT_MAX)
 1538 
   if ((double)nr * (double)nc > INT_MAX)
Line 1573... Line 1576...
1573 
    int k = asInteger(CAR(args)); args = CDR(args);
 1576 
    int k = asInteger(CAR(args)); args = CDR(args);
1574 
    /* k is the number of rows to be used: there must be at least that
 1577 
    /* k is the number of rows to be used: there must be at least that
1575 
       many rows and cols in the rhs and at least that many rows on
 1578 
       many rows and cols in the rhs and at least that many rows on
1576 
       the rhs.
 1579 
       the rhs.
1577 
    */
 1580 
    */
1578 
    if (k == NA_INTEGER || k <= 0 || k > nrr || k > ncols(r) || k > nrb)
1581 
    if (k == NA_INTEGER || k <= 0 || k > nrr || k > ncols(r) || k > nrb)
1579 
	error(_("invalid '%s' argument"), "k");
 1582 
	error(_("invalid '%s' argument"), "k");
1580 
    int upper = asLogical(CAR(args)); args = CDR(args);
 1583 
    int upper = asLogical(CAR(args)); args = CDR(args);
1581 
    if (upper == NA_INTEGER) error(_("invalid '%s' argument"), "upper.tri");
 1584 
    if (upper == NA_INTEGER) error(_("invalid '%s' argument"), "upper.tri");
1582 
    int trans = asLogical(CAR(args));
 1585 
    int trans = asLogical(CAR(args));
1583 
    if (trans == NA_INTEGER) error(_("invalid '%s' argument"), "transpose");
 1586 
    if (trans == NA_INTEGER) error(_("invalid '%s' argument"), "transpose");
Line 1598... Line 1601...
1598 
    if (k > 0 && ncb > 0) {
 1601 
    if (k > 0 && ncb > 0) {
1599 
       /* copy (part) cols of b to ans */
 1602 
       /* copy (part) cols of b to ans */
1600 
	for(R_xlen_t j = 0; j < ncb; j++)
 1603 
	for(R_xlen_t j = 0; j < ncb; j++)
1601 
	    memcpy(REAL(ans) + j*k, REAL(b) + j*nrb, (size_t)k *sizeof(double));
 1604 
	    memcpy(REAL(ans) + j*k, REAL(b) + j*nrb, (size_t)k *sizeof(double));
1602 
	double one = 1.0;
 1605 
	double one = 1.0;
1603 
	F77_CALL(dtrsm)("L", upper ? "U" : "L", trans ? "T" : "N", "N",
1606 
	F77_CALL(dtrsm)("L", upper ? "U" : "L", trans ? "T" : "N", "N",
1604 
			&k, &ncb, &one, rr, &nrr, REAL(ans), &k);
 1607 
			&k, &ncb, &one, rr, &nrr, REAL(ans), &k);
1605 
    }
 1608 
    }
1606 
    UNPROTECT(nprot);
 1609 
    UNPROTECT(nprot);
1607 
    return ans;
 1610 
    return ans;
1608 
}
 1611 
}