The R Project SVN R

/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 2000-10  The R Development Core Team
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  http://www.r-project.org/Licenses/
 */

#ifdef HAVE_CONFIG_H
#include <config.h>
#endif

#include <Defn.h>

/* .Internal(lapply(X, FUN)) */

/* This is a special .Internal, so has unevaluated arguments.  It is
   called from a closure wrapper, so X and FUN are promises. */
SEXP attribute_hidden do_lapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP R_fcall, ans, names, X, XX, FUN;
    int i, n;
    PROTECT_INDEX px;

    checkArity(op, args);
    PROTECT_WITH_INDEX(X = CAR(args), &px);
    PROTECT(XX = eval(CAR(args), rho));
    FUN = CADR(args);  /* must be unevaluated for use in e.g. bquote */
    n = length(XX);
    if (n == NA_INTEGER) error(_("invalid length"));

    PROTECT(ans = allocVector(VECSXP, n));
    names = getAttrib(XX, R_NamesSymbol);
    if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);

    /* The R level code has ensured that XX is a vector.
       If it is atomic we can speed things up slightly by
       using the evaluated version.
    */
    {
    SEXP ind, tmp;
    /* Build call: FUN(XX[[<ind>]], ...) */

    /* Notice that it is OK to have one arg to LCONS do memory
       allocation and not PROTECT the result (LCONS does memory
       protection of its args internally), but not both of them,
       since the computation of one may destroy the other */

    PROTECT(ind = allocVector(INTSXP, 1));
    if(isVectorAtomic(XX))
        PROTECT(tmp = LCONS(R_Bracket2Symbol,
                LCONS(XX, LCONS(ind, R_NilValue))));
    else
        PROTECT(tmp = LCONS(R_Bracket2Symbol,
                LCONS(X, LCONS(ind, R_NilValue))));
    PROTECT(R_fcall = LCONS(FUN,
                LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));

    for(i = 0; i < n; i++) {
        INTEGER(ind)[0] = i + 1;
        SET_VECTOR_ELT(ans, i, eval(R_fcall, rho));
    }
    UNPROTECT(3);
    }

    UNPROTECT(3); /* X, XX, ans */
    return ans;
}

/* .Internal(vapply(X, FUN, FUN.VALUE, USE.NAMES)) */

/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP R_fcall, ans, names=R_NilValue, rowNames=R_NilValue, X, XX, FUN, value;
    int i, n, commonLen, useNames;
    SEXPTYPE commonType;
    PROTECT_INDEX index;
    
    checkArity(op, args);
    PROTECT(X = CAR(args));
    PROTECT(XX = eval(CAR(args), rho));
    FUN = CADR(args);  /* must be unevaluated for use in e.g. bquote */
    PROTECT(value = eval(CADDR(args), rho));
    if (!isVector(value)) error(_("FUN.VALUE must be a vector"));
    useNames = asLogical(eval(CADDDR(args), rho));
    if (useNames == NA_LOGICAL) error(_("invalid USE.NAMES value"));
    
    n = length(XX);
    if (n == NA_INTEGER) error(_("invalid length"));

    commonLen = length(value);
    commonType = TYPEOF(value);
    
    PROTECT(ans = allocVector(commonType, n*commonLen));
    if (useNames) {
        PROTECT(names = getAttrib(XX, R_NamesSymbol));
        if (isNull(names) && TYPEOF(XX) == STRSXP) {
            UNPROTECT(1);
            PROTECT(names = XX);
        }
        PROTECT_WITH_INDEX(rowNames = getAttrib(value, R_NamesSymbol), &index);
    }
    /* The R level code has ensured that XX is a vector.
       If it is atomic we can speed things up slightly by
       using the evaluated version.
    */
    {
    SEXP ind, tmp;
    /* Build call: FUN(XX[[<ind>]], ...) */

    /* Notice that it is OK to have one arg to LCONS do memory
       allocation and not PROTECT the result (LCONS does memory
       protection of its args internally), but not both of them,
       since the computation of one may destroy the other */

    PROTECT(ind = allocVector(INTSXP, 1));
    if(isVectorAtomic(XX))
        PROTECT(tmp = LCONS(R_Bracket2Symbol,
                LCONS(XX, LCONS(ind, R_NilValue))));
    else
        PROTECT(tmp = LCONS(R_Bracket2Symbol,
                LCONS(X, LCONS(ind, R_NilValue))));
    PROTECT(R_fcall = LCONS(FUN,
                LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));

    for(i = 0; i < n; i++) {
        int j;
        SEXPTYPE tmpType;
        INTEGER(ind)[0] = i + 1;
        tmp = eval(R_fcall, rho);
        if (length(tmp) != commonLen) 
            error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
                   commonLen, i+1, length(tmp));
        tmpType = TYPEOF(tmp);
        if (tmpType != commonType) {
            Rboolean okay = FALSE;
            switch (commonType) {
            case CPLXSXP: okay = (tmpType == REALSXP) || (tmpType == INTSXP) 
                                || (tmpType == LGLSXP); break;
            case REALSXP: okay = (tmpType == INTSXP) || (tmpType == LGLSXP); break;
            case INTSXP:  okay = (tmpType == LGLSXP); break;
            }
            if (!okay)
                error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
                      type2char(commonType), i+1, type2char(tmpType));
            tmp = coerceVector(tmp, commonType);
        }
        /* Take row names from the first result only */
        if (i == 0 && useNames && isNull(rowNames)) 
            REPROTECT(rowNames = getAttrib(tmp, R_NamesSymbol), index);
            
        for (j = 0; j < commonLen; j++) {
            switch (commonType) {
            case CPLXSXP: COMPLEX(ans)[i*commonLen + j] = COMPLEX(tmp)[j]; break;
            case REALSXP: REAL(ans)[i*commonLen + j] = REAL(tmp)[j]; break;
            case INTSXP:  INTEGER(ans)[i*commonLen + j] = INTEGER(tmp)[j]; break;
            case LGLSXP:  LOGICAL(ans)[i*commonLen + j] = LOGICAL(tmp)[j]; break;
            case RAWSXP:  RAW(ans)[i*commonLen + j] = RAW(tmp)[j]; break;
            case STRSXP:  SET_STRING_ELT(ans, i*commonLen + j, STRING_ELT(tmp, j)); break;
            case VECSXP:  SET_VECTOR_ELT(ans, i*commonLen + j, VECTOR_ELT(tmp, j)); break;
            default:
                error(_("type '%s' is not supported"), type2char(commonType));
            }
        }
    }
    UNPROTECT(3);
    }

    if (commonLen != 1) {
    SEXP dim;
    PROTECT(dim = allocVector(INTSXP, 2));
    INTEGER(dim)[0] = commonLen;
    INTEGER(dim)[1] = n;
    setAttrib(ans, R_DimSymbol, dim);
    UNPROTECT(1); 
    }
    
    if (useNames) {
    if (commonLen == 1) {
        if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
    } else {
        if (!isNull(names) || !isNull(rowNames)) {
        SEXP dimnames;
        PROTECT(dimnames = allocVector(VECSXP, 2));
        SET_VECTOR_ELT(dimnames, 0, rowNames);
        SET_VECTOR_ELT(dimnames, 1, names);
        setAttrib(ans, R_DimNamesSymbol, dimnames);
        UNPROTECT(1);    
        }
    }
    }       
    UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
    return ans;
}

static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,
           Rboolean replace, SEXP rho)
{
    SEXP ans, names, klass, R_fcall;
    int i, j, n;
    Rboolean matched = FALSE;

    /* if X is a list, recurse.  Otherwise if it matches classes call f */
    if(isNewList(X)) {
    n = length(X);
    PROTECT(ans = allocVector(VECSXP, n));
    names = getAttrib(X, R_NamesSymbol);
    /* or copy attributes if replace = TRUE? */
    if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
    for(i = 0; i < n; i++)
        SET_VECTOR_ELT(ans, i, do_one(VECTOR_ELT(X, i), FUN, classes,
                      deflt, replace, rho));
    UNPROTECT(1);
    return ans;
    }
    if(strcmp(CHAR(STRING_ELT(classes, 0)), "ANY") == 0) /* ASCII */
    matched = TRUE;
    else {
    PROTECT(klass = R_data_class(X, FALSE));
    for(i = 0; i < LENGTH(klass); i++)
        for(j = 0; j < length(classes); j++)
        if(Seql(STRING_ELT(klass, i), STRING_ELT(classes, j)))
            matched = TRUE;
    UNPROTECT(1);
    }
    if(matched) {
    /* PROTECT(R_fcall = lang2(FUN, X)); */
    PROTECT(R_fcall = lang3(FUN, X, R_DotsSymbol));
    ans = eval(R_fcall, rho);
    UNPROTECT(1);
    return(ans);
    } else if(replace) return duplicate(X);
    else return duplicate(deflt);
}

SEXP attribute_hidden do_rapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP X, FUN, classes, deflt, how, ans, names;
    int i, n;
    Rboolean replace;

    checkArity(op, args);
    X = CAR(args); args = CDR(args);
    FUN = CAR(args); args = CDR(args);
    if(!isFunction(FUN)) error(_("invalid '%s' argument"), "f");
    classes = CAR(args); args = CDR(args);
    if(!isString(classes)) error(_("invalid '%s' argument"), "classes");
    deflt = CAR(args); args = CDR(args);
    how = CAR(args);
    if(!isString(how)) error(_("invalid '%s' argument"), "how");
    replace = strcmp(CHAR(STRING_ELT(how, 0)), "replace") == 0; /* ASCII */
    n = length(X);
    PROTECT(ans = allocVector(VECSXP, n));
    names = getAttrib(X, R_NamesSymbol);
    /* or copy attributes if replace = TRUE? */
    if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
    for(i = 0; i < n; i++)
    SET_VECTOR_ELT(ans, i, do_one(VECTOR_ELT(X, i), FUN, classes, deflt,
                      replace, rho));
    UNPROTECT(1);
    return ans;
}

static Rboolean islistfactor(SEXP X)
{
    int i, n = length(X);

    if(n == 0) return FALSE;
    switch(TYPEOF(X)) {
    case VECSXP:
    case EXPRSXP:
    for(i = 0; i < LENGTH(X); i++)
        if(!islistfactor(VECTOR_ELT(X, i))) return FALSE;
    return TRUE;
    break;
    }
    return isFactor(X);
}


/* is this a tree with only factor leaves? */

SEXP attribute_hidden do_islistfactor(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP X;
    Rboolean lans = TRUE, recursive;
    int i, n;

    checkArity(op, args);
    X = CAR(args);
    recursive = asLogical(CADR(args));
    n = length(X);
    if(n == 0 || !isVectorList(X)) {
    lans = FALSE;
    goto do_ans;
    }
    if(!recursive) {
    for(i = 0; i < LENGTH(X); i++)
    if(!isFactor(VECTOR_ELT(X, i))) {
        lans = FALSE;
        break;
    }
    } else {
    switch(TYPEOF(X)) {
    case VECSXP:
    case EXPRSXP:
        break;
    default:
        goto do_ans;
    }
    for(i = 0; i < LENGTH(X); i++)
        if(!islistfactor(VECTOR_ELT(X, i))) {
        lans = FALSE;
        break;
        }
    }
do_ans:
    return ScalarLogical(lans);
}