The R Project SVN R

/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *  Copyright (C) 1999-2004   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"


static SEXP lunary(SEXP, SEXP, SEXP);
static SEXP lbinary(SEXP, SEXP, SEXP);
static SEXP binaryLogic(int code, SEXP s1, SEXP s2);
static SEXP binaryLogic2(int code, SEXP s1, SEXP s2);


/* & | ! */
SEXP attribute_hidden do_logic(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans;

    if (DispatchGroup("Ops",call, op, args, env, &ans))
    return ans;
    switch (length(args)) {
    case 1:
    return lunary(call, op, CAR(args));
    case 2:
    return lbinary(call, op, args);
    default:
    error(_("binary operations require two arguments"));
    return R_NilValue;  /* for -Wall */
    }
}

#define isRaw(x) (TYPEOF(x) == RAWSXP)
static SEXP lbinary(SEXP call, SEXP op, SEXP args)
{
/* logical binary : "&" or "|" */
    SEXP x, y, dims, tsp, klass, xnames, ynames;
    int mismatch, nx, ny, xarray, yarray, xts, yts;
    mismatch = 0;
    x = CAR(args);
    y = CADR(args);
    if (isRaw(x) && isRaw(y)) {
    } else if (!isNumeric(x) || !isNumeric(y))
    errorcall(call,
          _("operations are possible only for numeric or logical types"));
    tsp = R_NilValue;       /* -Wall */
    klass = R_NilValue;     /* -Wall */
    xarray = isArray(x);
    yarray = isArray(y);
    xts = isTs(x);
    yts = isTs(y);
    if (xarray || yarray) {
    if (xarray && yarray) {
        if (!conformable(x, y))
        error(_("binary operation on non-conformable arrays"));
        PROTECT(dims = getAttrib(x, R_DimSymbol));
    }
    else if (xarray) {
        PROTECT(dims = getAttrib(x, R_DimSymbol));
    }
    else /*(yarray)*/ {
        PROTECT(dims = getAttrib(y, R_DimSymbol));
    }
    PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
    PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
    }
    else {
    PROTECT(dims = R_NilValue);
    PROTECT(xnames = getAttrib(x, R_NamesSymbol));
    PROTECT(ynames = getAttrib(y, R_NamesSymbol));
    }
    nx = length(x);
    ny = length(y);
    if(nx > 0 && ny > 0) {
    if(nx > ny) mismatch = nx % ny;
    else mismatch = ny % nx;
    }
    if (xts || yts) {
    if (xts && yts) {
        if (!tsConform(x, y))
        errorcall(call, _("non-conformable time series"));
        PROTECT(tsp = getAttrib(x, R_TspSymbol));
        PROTECT(klass = getAttrib(x, R_ClassSymbol));
    }
    else if (xts) {
        if (length(x) < length(y))
        ErrorMessage(call, ERROR_TSVEC_MISMATCH);
        PROTECT(tsp = getAttrib(x, R_TspSymbol));
        PROTECT(klass = getAttrib(x, R_ClassSymbol));
    }
    else /*(yts)*/ {
        if (length(y) < length(x))
        ErrorMessage(call, ERROR_TSVEC_MISMATCH);
        PROTECT(tsp = getAttrib(y, R_TspSymbol));
        PROTECT(klass = getAttrib(y, R_ClassSymbol));
    }
    }
    if(mismatch)
    warningcall(call,
            _("longer object length is not a multiple of shorter object length"));

    if (isRaw(x) && isRaw(y)) {
    PROTECT(x = binaryLogic2(PRIMVAL(op), x, y));
    } else {
    if (!isNumeric(x) || !isNumeric(y))
        errorcall(call,
              _("operations are possible only for numeric or logical types"));
    x = SETCAR(args, coerceVector(x, LGLSXP));
    y = SETCADR(args, coerceVector(y, LGLSXP));
    PROTECT(x = binaryLogic(PRIMVAL(op), x, y));
    }


    if (dims != R_NilValue) {
    setAttrib(x, R_DimSymbol, dims);
    if(xnames != R_NilValue)
        setAttrib(x, R_DimNamesSymbol, xnames);
    else if(ynames != R_NilValue)
        setAttrib(x, R_DimNamesSymbol, ynames);
    }
    else {
    if(length(x) == length(xnames))
        setAttrib(x, R_NamesSymbol, xnames);
    else if(length(x) == length(ynames))
        setAttrib(x, R_NamesSymbol, ynames);
    }

    if (xts || yts) {
    setAttrib(x, R_TspSymbol, tsp);
    setAttrib(x, R_ClassSymbol, klass);
    UNPROTECT(2);
    }
    UNPROTECT(4);
    return x;
}

static SEXP lunary(SEXP call, SEXP op, SEXP arg)
{
    SEXP x, dim, dimnames, names;
    int i, len;

    len = LENGTH(arg);
    if(len == 0) return(allocVector(LGLSXP, 0));
    if (!isLogical(arg) && !isNumeric(arg) && !isRaw(arg))
    errorcall(call, _("invalid argument type"));
    PROTECT(names = getAttrib(arg, R_NamesSymbol));
    PROTECT(dim = getAttrib(arg, R_DimSymbol));
    PROTECT(dimnames = getAttrib(arg, R_DimNamesSymbol));
    PROTECT(x = allocVector(isRaw(arg)?RAWSXP:LGLSXP, len));
    switch(TYPEOF(arg)) {
    case LGLSXP:
    for (i = 0; i < len; i++)
        LOGICAL(x)[i] = (LOGICAL(arg)[i] == NA_LOGICAL) ?
        NA_LOGICAL : LOGICAL(arg)[i] == 0;
    break;
    case INTSXP:
    for (i = 0; i < len; i++)
        LOGICAL(x)[i] = (INTEGER(arg)[i] == NA_INTEGER) ?
        NA_LOGICAL : INTEGER(arg)[i] == 0;
    break;
    case REALSXP:
    for (i = 0; i < len; i++)
        LOGICAL(x)[i] = ISNAN(REAL(arg)[i]) ?
        NA_LOGICAL : REAL(arg)[i] == 0;
    break;
    case RAWSXP:
    for (i = 0; i < len; i++)
        RAW(x)[i] = 0xFF ^ RAW(arg)[i];
    break;
    default:
    UNIMPLEMENTED_TYPE("lunary", arg);
    }
    if(names != R_NilValue) setAttrib(x, R_NamesSymbol, names);
    if(dim != R_NilValue) setAttrib(x, R_DimSymbol, dim);
    if(dimnames != R_NilValue) setAttrib(x, R_DimNamesSymbol, dimnames);
    UNPROTECT(4);
    return x;
}

/* && || */
SEXP attribute_hidden do_logic2(SEXP call, SEXP op, SEXP args, SEXP env)
{
/*  &&  and  ||  */
    SEXP s1, s2;
    int x1, x2;
    SEXP ans;

    if (length(args) != 2)
    error(_("'%s' operator requires 2 arguments"),
          PRIMVAL(op) == 1 ? "&&" : "||");

    s1 = CAR(args);
    s2 = CADR(args);
    PROTECT(ans = allocVector(LGLSXP, 1));
    s1 = eval(s1, env);
    if (!isNumeric(s1))
    errorcall(call, _("invalid 'x' type in 'x %s y'"),
          PRIMVAL(op) == 1 ? "&&" : "||");
    x1 = asLogical(s1);

#define get_2nd                         \
    s2 = eval(s2, env);                 \
    if (!isNumeric(s2))                 \
        errorcall(call, _("invalid 'y' type in 'x %s y'"),  \
              PRIMVAL(op) == 1 ? "&&" : "||");      \
    x2 = asLogical(s2);

    switch (PRIMVAL(op)) {
    case 1: /* && */
    if (x1 == FALSE)
        LOGICAL(ans)[0] = FALSE;
    else {
        get_2nd;
        if (x1 == NA_LOGICAL)
        LOGICAL(ans)[0] = (x2 == NA_LOGICAL || x2) ? NA_LOGICAL : x2;
        else /* x1 == TRUE */
        LOGICAL(ans)[0] = x2;
    }
    break;
    case 2: /* || */
    if (x1 == TRUE)
        LOGICAL(ans)[0] = TRUE;
    else {
        get_2nd;
        if (x1 == NA_LOGICAL)
        LOGICAL(ans)[0] = (x2 == NA_LOGICAL || !x2) ? NA_LOGICAL : x2;
        else /* x1 == FALSE */
        LOGICAL(ans)[0] = x2;
    }
    }
    UNPROTECT(1);
    return ans;
}

static SEXP binaryLogic(int code, SEXP s1, SEXP s2)
{
    int i, n, n1, n2;
    int x1, x2;
    SEXP ans;

    n1 = LENGTH(s1);
    n2 = LENGTH(s2);
    n = (n1 > n2) ? n1 : n2;
    if (n1 == 0 || n2 == 0) {
    ans = allocVector(LGLSXP, 0);
    return ans;
    }
    ans = allocVector(LGLSXP, n);

    switch (code) {
    case 1:     /* & : AND */
    for (i = 0; i < n; i++) {
        x1 = LOGICAL(s1)[i % n1];
        x2 = LOGICAL(s2)[i % n2];
        if (x1 == 0 || x2 == 0)
        LOGICAL(ans)[i] = 0;
        else if (x1 == NA_LOGICAL || x2 == NA_LOGICAL)
        LOGICAL(ans)[i] = NA_LOGICAL;
        else
        LOGICAL(ans)[i] = 1;
    }
    break;
    case 2:     /* | : OR */
    for (i = 0; i < n; i++) {
        x1 = LOGICAL(s1)[i % n1];
        x2 = LOGICAL(s2)[i % n2];
        if ((x1 != NA_LOGICAL && x1) || (x2 != NA_LOGICAL && x2))
        LOGICAL(ans)[i] = 1;
        else if (x1 == 0 && x2 == 0)
        LOGICAL(ans)[i] = 0;
        else
        LOGICAL(ans)[i] = NA_LOGICAL;
    }
    break;
    case 3:
    error(_("Unary operator `!' called with two arguments"));
    break;
    }
    return ans;
}

static SEXP binaryLogic2(int code, SEXP s1, SEXP s2)
{
    int i, n, n1, n2;
    int x1, x2;
    SEXP ans;

    n1 = LENGTH(s1);
    n2 = LENGTH(s2);
    n = (n1 > n2) ? n1 : n2;
    if (n1 == 0 || n2 == 0) {
    ans = allocVector(RAWSXP, 0);
    return ans;
    }
    ans = allocVector(RAWSXP, n);

    switch (code) {
    case 1:     /* & : AND */
    for (i = 0; i < n; i++) {
        x1 = RAW(s1)[i % n1];
        x2 = RAW(s2)[i % n2];
        RAW(ans)[i] = x1 & x2;
    }
    break;
    case 2:     /* | : OR */
    for (i = 0; i < n; i++) {
        x1 = RAW(s1)[i % n1];
        x2 = RAW(s2)[i % n2];
        RAW(ans)[i] = x1 | x2;
    }
    break;
    }
    return ans;
}

static void checkValues(int * x, int n, Rboolean *haveFalse,
            Rboolean *haveTrue, Rboolean *haveNA)
{
    int i;
    for (i = 0; i < n; i++) {
    if (x[i] == NA_LOGICAL)
        *haveNA = TRUE;
    else if (x[i])
        *haveTrue = TRUE;
    else
        *haveFalse = TRUE;
    }
}

extern SEXP fixup_NaRm(SEXP args); /* summary.c */

/* all, any */
SEXP attribute_hidden do_logic3(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, s, t, call2;
    int narm;
    Rboolean haveTrue;
    Rboolean haveFalse;
    Rboolean haveNA;

    PROTECT(args = fixup_NaRm(args));
    PROTECT(call2 = duplicate(call));
    SETCDR(call2, args);

    if (DispatchGroup("Summary", call2, op, args, env, &ans)) {
    UNPROTECT(2);
    return(ans);
    }

    ans = matchArgExact(R_NaRmSymbol, &args);
    narm = asLogical(ans);
    haveTrue = FALSE;
    haveFalse = FALSE;
    haveNA = FALSE;

    for (s = args; s != R_NilValue; s = CDR(s)) {
    t = CAR(s);
    /* Avoid memeory waste from coercing empty inputs, and also
       avoid warnings with empty lists coming from sapply */
    if(length(t) == 0) continue;
    /* coerceVector protects its argument so this actually works
       just fine */
    if (TYPEOF(t)  != LGLSXP) {
        /* Coercion of integers seems reasonably safe, but for
           other types it is more often than not an error.
           One exception is perhaps the result of lapply, but
           then sapply was often what was intended. */
        if(TYPEOF(t) != INTSXP)
        warningcall(call,
                _("coercing argument of type '%s' to logical"),
                type2char(TYPEOF(t)));
        t = coerceVector(t, LGLSXP);
    }
    checkValues(LOGICAL(t), LENGTH(t), &haveFalse, &haveTrue, &haveNA);
    }
    if (narm)
    haveNA = FALSE;

    s = allocVector(LGLSXP, 1L);
    if (PRIMVAL(op) == 1) { /* ALL */
    LOGICAL(s)[0] = haveNA ? (haveFalse ? FALSE : NA_LOGICAL) : !haveFalse;
    } else {            /* ANY */
    LOGICAL(s)[0] = haveNA ? (haveTrue  ? TRUE  : NA_LOGICAL) : haveTrue;
    }
    UNPROTECT(2);
    return s;
}