The R Project SVN R

Rev

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

Rev 16707 Rev 17515
Line 272... Line 272...
272 
 
 272 
 
273 
    if (length(args) != 1)
 273 
    if (length(args) != 1)
274 
	error("incorrect number of args to length");
 274 
	error("incorrect number of args to length");
275 
 
 275 
 
276 
    if( isObject(CAR(args)) && DispatchOrEval(call, op, "length", args,
 276 
    if( isObject(CAR(args)) && DispatchOrEval(call, op, "length", args,
277 
					      rho, &ans, 0, 1))
277 
					      rho, &ans, 0, 1))
278 
      return(ans);
 278 
      return(ans);
279
279 
 
280 
    ans = allocVector(INTSXP, 1);
 280 
    ans = allocVector(INTSXP, 1);
281 
    INTEGER(ans)[0] = length(CAR(args));
 281 
    INTEGER(ans)[0] = length(CAR(args));
282 
    return ans;
 282 
    return ans;
283 
}
 283 
}
284 
 
 284 
 
Line 323... Line 323...
323 
    if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {
 323 
    if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) {
324 
        F77_CALL(dgemm)(transa, transb, &nrx, &ncy, &ncx, &one,
 324 
        F77_CALL(dgemm)(transa, transb, &nrx, &ncy, &ncx, &one,
325 
		    x, &nrx, y, &nry, &zero, z, &nrx);
 325 
		    x, &nrx, y, &nry, &zero, z, &nrx);
326 
    }
 326 
    }
327 
    else { /* zero-extent operations should return zeroes */
 327 
    else { /* zero-extent operations should return zeroes */
328 
	for(i=0;i<nrx*ncy;i++)
328 
	for(i=0;i<nrx*ncy;i++)
329 
	    z[i]=0;
 329 
	    z[i]=0;
330 
    }
 330 
    }
331 
#else
 331 
#else
332 
 
 332 
 
333 
/* FIXME - What about non-IEEE overflow ??? */
 333 
/* FIXME - What about non-IEEE overflow ??? */
Line 774... Line 774...
774 
	    iip[itmp]++;				\
 774 
	    iip[itmp]++;				\
775 
	    break;					\
 775 
	    break;					\
776 
	}						\
 776 
	}						\
777 
    for (j=0, itmp=0; itmp<n; itmp++)			\
 777 
    for (j=0, itmp=0; itmp<n; itmp++)			\
778 
	j += iip[itmp] * stride[itmp];
 778 
	j += iip[itmp] * stride[itmp];
779
779 
 
780 
/* aperm (a, perm, resize = TRUE) */
 780 
/* aperm (a, perm, resize = TRUE) */
781 
SEXP do_aperm(SEXP call, SEXP op, SEXP args, SEXP rho)
 781 
SEXP do_aperm(SEXP call, SEXP op, SEXP args, SEXP rho)
782 
{
 782 
{
783 
    SEXP a, perm, resize, r, dimsa, dimsr, dna;
 783 
    SEXP a, perm, resize, r, dimsa, dimsr, dna;
784 
    int i, j, n, len, itmp;
 784 
    int i, j, n, len, itmp;
Line 889... Line 889...
889 
	break;
 889 
	break;
890 
 
 890 
 
891 
    default:
 891 
    default:
892 
	errorcall(call, "unsupported type of array");
 892 
	errorcall(call, "unsupported type of array");
893 
    }
 893 
    }
894
894 
 
895 
    /* handle the resize */
 895 
    /* handle the resize */
896 
    PROTECT(resize = coerceVector(CADDR(args), INTSXP));
 896 
    PROTECT(resize = coerceVector(CADDR(args), INTSXP));
897 
    if (LOGICAL(resize)[0])
 897 
    if (LOGICAL(resize)[0])
898 
	setAttrib(r, R_DimSymbol, dimsr);
 898 
	setAttrib(r, R_DimSymbol, dimsr);
899 
    else
 899 
    else
Line 922... Line 922...
922 
	setAttrib(r, R_DimNamesSymbol, dnr);
 922 
	setAttrib(r, R_DimNamesSymbol, dnr);
923 
	UNPROTECT(3); /* dnna, dnr, dnnr */
 923 
	UNPROTECT(3); /* dnna, dnr, dnnr */
924 
    }
 924 
    }
925 
    /* free temporary memory */
 925 
    /* free temporary memory */
926 
    vmaxset(vmax);
 926 
    vmaxset(vmax);
927
927 
 
928 
    UNPROTECT(6); /* dimsa, perm, r, dimsr, resize, dna */
 928 
    UNPROTECT(6); /* dimsa, perm, r, dimsr, resize, dna */
929 
    return r;
 929 
    return r;
930 
}
 930 
}
- 
 
 931 
 
- 
 
 932 
/* colSums(x, n, p, na.rm) and friends */
- 
 
 933 
SEXP do_colsum(SEXP call, SEXP op, SEXP args, SEXP rho)
- 
 
 934 
{
- 
 
 935 
    SEXP x, ans = R_NilValue;
- 
 
 936 
    int OP, n, p, cnt = 0, i, j, type;
- 
 
 937 
    Rboolean NaRm;
- 
 
 938 
    int *ix;
- 
 
 939 
    double *rx, sum = 0.0;
- 
 
 940 
    /* Rcomplex cx, csum;*/
- 
 
 941 
 
- 
 
 942 
    checkArity(op, args);
- 
 
 943 
    x = CAR(args); args = CDR(args);
- 
 
 944 
    n = asInteger(CAR(args)); args = CDR(args);
- 
 
 945 
    p = asInteger(CAR(args)); args = CDR(args);
- 
 
 946 
    NaRm = asLogical(CAR(args));
- 
 
 947 
    if(n == NA_INTEGER || n <= 0)
- 
 
 948 
	errorcall(call, "invalid value of n");
- 
 
 949 
    if(p == NA_INTEGER || p <= 0)
- 
 
 950 
	errorcall(call, "invalid value of p");
- 
 
 951 
    if(NaRm == NA_LOGICAL) errorcall(call, "invalid value of na.rm");
- 
 
 952 
 
- 
 
 953 
    OP = PRIMVAL(op);
- 
 
 954 
    switch (type = TYPEOF(x)) {
- 
 
 955 
    case LGLSXP: break;
- 
 
 956 
    case INTSXP: break;
- 
 
 957 
    case REALSXP: break;
- 
 
 958 
/*    case CPLXSXP: break; */
- 
 
 959 
    default:
- 
 
 960 
	errorcall(call, "`x' must be numeric");
- 
 
 961 
    }
- 
 
 962 
 
- 
 
 963 
    if(OP == 0 || OP == 1) { /* columns */
- 
 
 964 
	PROTECT(ans = allocVector(REALSXP, p));
- 
 
 965 
	for (j = 0; j < p; j++) {
- 
 
 966 
	    switch (type) {
- 
 
 967 
	    case REALSXP:
- 
 
 968 
		rx = REAL(x);
- 
 
 969 
		for (cnt = 0, sum = 0., i = 0; i < n; i++)
- 
 
 970 
		    if(!ISNAN(rx[i+n*j])) {cnt++; sum += rx[i+n*j];}
- 
 
 971 
		    else if(!NaRm) {sum = NA_REAL; break;}
- 
 
 972 
		break;
- 
 
 973 
	    case INTSXP:
- 
 
 974 
		ix = INTEGER(x);
- 
 
 975 
		for (cnt = 0, sum = 0., i = 0; i < n; i++)
- 
 
 976 
		    if(ix[i+n*j] != NA_INTEGER) {cnt++; sum += ix[i+n*j];}
- 
 
 977 
		    else if(!NaRm) {sum = NA_REAL; break;}
- 
 
 978 
		break;
- 
 
 979 
	    case LGLSXP:
- 
 
 980 
		ix = LOGICAL(x);
- 
 
 981 
		for (cnt = 0, sum = 0., i = 0; i < n; i++)
- 
 
 982 
		    if(ix[i+n*j] != NA_LOGICAL) {cnt++; sum += ix[i+n*j];}
- 
 
 983 
		    else if(!NaRm) {sum = NA_REAL; break;}
- 
 
 984 
		break;
- 
 
 985 
	    }
- 
 
 986 
	    if(OP == 1) {
- 
 
 987 
		if(cnt > 0) sum /= cnt; else sum = NA_REAL;
- 
 
 988 
	    }
- 
 
 989 
	    REAL(ans)[j] = sum;
- 
 
 990 
	}
- 
 
 991 
    }
- 
 
 992 
 
- 
 
 993 
    if(OP == 2 || OP == 3) { /* rows */
- 
 
 994 
	PROTECT(ans = allocVector(REALSXP, n));
- 
 
 995 
	for (i = 0; i < n; i++) {
- 
 
 996 
	    switch (type) {
- 
 
 997 
	    case REALSXP:
- 
 
 998 
		rx = REAL(x);
- 
 
 999 
		for (cnt = 0, sum = 0., j = 0; j < p; j++)
- 
 
 1000 
		    if(!ISNAN(rx[i+n*j])) {cnt++; sum += rx[i+n*j];}
- 
 
 1001 
		    else if(!NaRm) {sum = NA_REAL; break;}
- 
 
 1002 
		break;
- 
 
 1003 
	    case INTSXP:
- 
 
 1004 
		ix = INTEGER(x);
- 
 
 1005 
		for (cnt = 0, sum = 0., j = 0; j < p; j++)
- 
 
 1006 
		    if(ix[i+n*j] != NA_INTEGER) {cnt++; sum += ix[i+n*j];}
- 
 
 1007 
		    else if(!NaRm) {sum = NA_REAL; break;}
- 
 
 1008 
		break;
- 
 
 1009 
	    case LGLSXP:
- 
 
 1010 
		ix = LOGICAL(x);
- 
 
 1011 
		for (cnt = 0, sum = 0., j = 0; j < p; j++)
- 
 
 1012 
		    if(ix[i+n*j] != NA_LOGICAL) {cnt++; sum += ix[i+n*j];}
- 
 
 1013 
		    else if(!NaRm) {sum = NA_REAL; break;}
- 
 
 1014 
		break;
- 
 
 1015 
	    }
- 
 
 1016 
	    if(OP == 3) {
- 
 
 1017 
		if(cnt > 0) sum /= cnt; else sum = NA_REAL;
- 
 
 1018 
	    }
- 
 
 1019 
	    REAL(ans)[i] = sum;
- 
 
 1020 
	}
- 
 
 1021 
    }
- 
 
 1022 
 
- 
 
 1023 
    UNPROTECT(1);
- 
 
 1024 
    return ans;
- 
 
 1025 
}