The R Project SVN R

/*
 *  R : A Computer Langage for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *
 *  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, write to the Free Software
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

#include "Defn.h"

#define NIL -1

/* Hash function and equality test for keys */
static int K, M;
static int(*hash) (SEXP, int);
static int(*equal) (SEXP, int, SEXP, int);
static SEXP HashTable;

static int nomatch;

/*
 *    Integer keys are hashed via a random number generator
 *      based on Knuth's recommendations.  The high order K bits
 *      are used as the hash code.
 *      WARNING: this doesn't work if K=0 so some fixes/warnings
 *      probably need to be installed somewhere. (RG)
 */

static int scatter(unsigned int key)
{
    return 3141592653U * key >> (32 - K);
}

static int lhash(SEXP x, int index)
{
    if (LOGICAL(x)[index] == NA_LOGICAL)
        return 2;
    return LOGICAL(x)[index];
}

static int ihash(SEXP x, int index)
{
    if (INTEGER(x)[index] == NA_INTEGER)
        return 0;
    return scatter((unsigned int) (INTEGER(x)[index]));
}

static int rhash(SEXP x, int index)
{
    /* There is a problem with signed 0s */
    double tmp = (REAL(x)[index] == 0.0) ? 0.0 : REAL(x)[index];
    return scatter(*((unsigned int *) (&tmp)));
}

#ifdef COMPLEX_DATA
static int chash(SEXP x, int index)
{
    complex tmp;
    tmp.r = (COMPLEX(x)[index].r == 0.0) ? 0.0 : COMPLEX(x)[index].r;
    tmp.i = (COMPLEX(x)[index].i == 0.0) ? 0.0 : COMPLEX(x)[index].i;
    return scatter((*((unsigned int *)(&tmp.r)) |
        (*((unsigned int *)(&tmp.r)))));
}
#endif

static int shash(SEXP x, int index)
{
    unsigned int k;
    char *p = CHAR(STRING(x)[index]);
    k = 0;
    while (*p++)
        k = 8 * k + *p;
    return scatter(k);
}

static int iequal(SEXP x, int i, SEXP y, int j)
{
    return (INTEGER(x)[i] == INTEGER(y)[j]);
}

static int requal(SEXP x, int i, SEXP y, int j)
{
    if(FINITE(REAL(x)[i]) && FINITE(REAL(y)[j])) {
        return (REAL(x)[i] == REAL(y)[j]);
    }
    else if(!FINITE(REAL(x)[i]) && !FINITE(REAL(y)[j])) {
        return 1;
    }
    return 0;
}

#ifdef COMPLEX_DATA
static int cequal(SEXP x, int i, SEXP y, int j)
{
    if(FINITE(COMPLEX(x)[i].r) && FINITE(COMPLEX(x)[i].i)
    && FINITE(COMPLEX(y)[j].r) && FINITE(COMPLEX(y)[j].i)) {
        return COMPLEX(x)[i].r == COMPLEX(y)[j].r &&
            COMPLEX(x)[i].i == COMPLEX(y)[j].i;
    }
    else if((!FINITE(COMPLEX(x)[i].r) || !FINITE(COMPLEX(x)[i].i))
         && (!FINITE(COMPLEX(y)[j].r) || !FINITE(COMPLEX(y)[j].i))) {
        return 1;
    }
    return 0;
}
#endif

static int sequal(SEXP x, int i, SEXP y, int j)
{
    return !strcmp(CHAR(STRING(x)[i]), CHAR(STRING(y)[j]));
}

/* Choose M to be the smallest power of 2 */
/* not less than 2*n and set K = log2(M) */
static void MKsetup(int n)
{
    int n2 = 2 * n;
    M = 1;
    K = 0;
    while (M < n2) {
        M *= 2;
        K += 1;
    }
}

void HashTableSetup(SEXP x)
{
    switch (TYPEOF(x)) {
    case LGLSXP:
        hash = lhash;
        equal = iequal;
        MKsetup(3);
        break;
    case FACTSXP:
    case ORDSXP:
        hash = ihash;
        equal = iequal;
        MKsetup(LEVELS(x) + 1);
        break;
    case INTSXP:
        hash = ihash;
        equal = iequal;
        MKsetup(LENGTH(x));
        break;
    case REALSXP:
        hash = rhash;
        equal = requal;
        MKsetup(LENGTH(x));
        break;
#ifdef COMPLEX_DATA
    case CPLXSXP:
        hash = chash;
        equal = cequal;
        MKsetup(LENGTH(x));
        break;
#endif
    case STRSXP:
        hash = shash;
        equal = sequal;
        MKsetup(LENGTH(x));
        break;
    }
    HashTable = allocVector(INTSXP, M);
}

/* Open address hashing */
/* Collision resolution is by linear probing */
/* The table is guaranteed large so this is sufficient */

static int isDuplicated(SEXP x, int index)
{
    int i, *h;

    h = INTEGER(HashTable);
    i = hash(x, index);
    while (h[i] != NIL) {
        if (equal(x, h[i], x, index))
            return 1;
        i = (i + 1) % M;
    }
    h[i] = index;
    return 0;
}

SEXP duplicated(SEXP x)
{
    SEXP ans;
    int *h, *v;
    int i, n;

    n = LENGTH(x);
    HashTableSetup(x);
    PROTECT(HashTable);
    ans = allocVector(LGLSXP, n);
    UNPROTECT(1);
    h = INTEGER(HashTable);
    v = LOGICAL(ans);

    for (i = 0; i < M; i++)
        h[i] = NIL;

    for (i = 0; i < n; i++)
        v[i] = isDuplicated(x, i);

    return ans;
}

SEXP do_duplicated(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP x, dup, ans;
    int i, k, n;

    checkArity(op, args);
    x = CAR(args);
    if (!isVector(x))
        error("duplicated applies only to vectors\n");

    /* handle zero length vectors */
    if (length(x) == 0) {
        if (PRIMVAL(op) == 0)
            return (allocVector(LGLSXP, 0));
        else
            return (allocVector(TYPEOF(x), 0));
    }

    /* code for "duplicated" */
    dup = duplicated(x);
    if (PRIMVAL(op) == 0)
        return dup;

    /* use the results of "duplicated" to get "unique" */
    n = LENGTH(x);

    /* count unique entries */
    k = 0;
    for (i = 0; i < n; i++)
        if (LOGICAL(dup)[i] == 0)
            k++;

    PROTECT(dup);
    ans = allocVector(TYPEOF(x), k);
    UNPROTECT(1);

    k = 0;
    switch (TYPEOF(x)) {
    case FACTSXP:
    case ORDSXP:
        LEVELS(ans) = LEVELS(x);
        setAttrib(ans, R_LevelsSymbol, getAttrib(x, R_LevelsSymbol));
    case LGLSXP:
    case INTSXP:
        for (i = 0; i < n; i++)
            if (LOGICAL(dup)[i] == 0)
                INTEGER(ans)[k++] = INTEGER(x)[i];
        break;
    case REALSXP:
        for (i = 0; i < n; i++)
            if (LOGICAL(dup)[i] == 0)
                REAL(ans)[k++] = REAL(x)[i];
        break;
#ifdef COMPLEX_DATA
    case CPLXSXP:
        for (i = 0; i < n; i++)
            if (LOGICAL(dup)[i] == 0) {
                COMPLEX(ans)[k].r = COMPLEX(x)[i].r;
                COMPLEX(ans)[k].i = COMPLEX(x)[i].i;
                k++;
            }
        break;
#endif
    case STRSXP:
        for (i = 0; i < n; i++)
            if (LOGICAL(dup)[i] == 0)
                STRING(ans)[k++] = STRING(x)[i];
        break;
    }
    return ans;
}

/* Build a hash table, ignoring information on duplication */
static void DoHashing(SEXP table)
{
    int *h, i, n;

    n = LENGTH(table);
    h = INTEGER(HashTable);

    for (i = 0; i < M; i++)
        h[i] = NIL;

    for (i = 0; i < n; i++)
        (void) isDuplicated(table, i);
}

static int Lookup(SEXP table, SEXP x, int index)
{
    int i, *h;

    h = INTEGER(HashTable);
    i = hash(x, index);
    while (h[i] != NIL) {
        if (equal(table, h[i], x, index))
            return h[i] + 1;
        i = (i + 1) % M;
    }
    return nomatch;
}

/* Now do the table lookup */
static SEXP HashLookup(SEXP table, SEXP x)
{
    SEXP ans;
    int i, n;

    n = LENGTH(x);
    ans = allocVector(INTSXP, n);
    for (i = 0; i < n; i++) {
        INTEGER(ans)[i] = Lookup(table, x, i);
    }
    return ans;
}

SEXP do_match(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP x, table, ans;
    SEXPTYPE type;
    int n, i;

    checkArity(op, args);

    if ((!isVector(CAR(args)) && !isNull(CAR(args)))
         || (!isVector(CADR(args)) && !isNull(CADR(args))))
        error("match requires vector arguments\n");

    /* Coerce to a common type */
    /* Note: type == NILSXP is ok here */

    type = TYPEOF(CAR(args)) < TYPEOF(CADR(args)) ?
        TYPEOF(CADR(args)) : TYPEOF(CAR(args));
    x = CAR(args) = coerceVector(CAR(args), type);
    table = CADR(args) = coerceVector(CADR(args), type);
    nomatch = asInteger(CAR(CDDR(args)));
    n = length(x);

    /* handle zero length arrays */
    if (n == 0) return allocVector(INTSXP, 0);
    if (length(table) == 0) {
        ans = allocVector(INTSXP, n);
        for (i = 0; i < n; i++)
            INTEGER(ans)[i] = nomatch;
        return ans;
    }

    HashTableSetup(table);
    PROTECT(HashTable);
    DoHashing(table);
    ans = HashLookup(table, x);
    UNPROTECT(1);
    return ans;
}

SEXP match(SEXP table, SEXP x, int nmatch)
{
    SEXP ans;

    nomatch=nmatch;
    HashTableSetup(table);
    PROTECT(HashTable);
    DoHashing(table);
    ans = HashLookup(table, x);
    UNPROTECT(1);
    return ans;
}

        /* Partial Matching of Strings */
        /* Loosely based on Therneau's charmatch */

SEXP do_pmatch(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, input, target;
    int i, j, k, match, n_input, n_target, perfect, temp;
    checkArity(op, args);

    input = CAR(args);
    n_input = LENGTH(input);
    target = CADR(args);
    n_target = LENGTH(target);

    if (!isString(input) || !isString(target))
        errorcall(call, "argument is not of mode character\n");

    ans = allocVector(INTSXP, n_input);

    for (i = 0; i < n_input; i++) {
        temp = strlen(CHAR(STRING(input)[i]));
        match = NA_INTEGER;
        perfect = 0;
        for (j = 0; j < n_target; j++) {
            k = strncmp(CHAR(STRING(input)[i]), CHAR(STRING(target)[j]), temp);
            if (k == 0) {
                if (strlen(CHAR(STRING(target)[j])) == temp) {
                    if (perfect == 1)
                        match = 0;
                    else {
                        perfect = 1;
                        match = j + 1;
                    }
                }
                else if (perfect == 0) {
                    if (match == NA_INTEGER)
                        match = j + 1;
                    else
                        match = 0;
                }
            }
        }
        INTEGER(ans)[i] = match;
    }
    return ans;
}

/* 
   matching the supplied arguments to the formal arguments;
   returned value is a list with all components named
*/

#define ARGUSED(x) LEVELS(x)

static SEXP StripUnmatched(SEXP s)
{
    if(s == R_NilValue) return s;

    if(CAR(s) == R_MissingArg) {
        return StripUnmatched(CDR(s));
    }
    else {
        CDR(s) = StripUnmatched(CDR(s));
        return s;
    }
}

static SEXP ExpandDots(SEXP s, int expdots)
{
    SEXP r;

    if(s == R_NilValue) return s;

    if(TYPEOF(CAR(s)) == DOTSXP ) {
        TYPEOF(CAR(s)) = LISTSXP;   /* a safe mutation */
        if(expdots) {
            r = CAR(s);
            while (CDR(r) != R_NilValue )
                r = CDR(r);
            CDR(r)= ExpandDots(CDR(s), expdots);
            return CAR(s);
        }
    }
    CDR(s) = ExpandDots(CDR(s), expdots);
    return s;
}

SEXP do_matchcall(SEXP call, SEXP op, SEXP args, SEXP env)
{
        SEXP formals, actuals, rlist;
    SEXP f, b, rval;
    int expdots;

    checkArity(op,args);

    f = CADR(args);

    if(TYPEOF(f) != LANGSXP) {
        b = deparse1(f, 1);
        errorcall(call, "%s is not a valid call\n", CHAR(STRING(b)[0]));
    }

        /* Get the function definition */

    if(TYPEOF(CAR(args)) == NILSXP) {
        if( TYPEOF(CAR(f)) == SYMSXP )
            PROTECT(b = findFun(CAR(f), env));
        else
            PROTECT(b = eval(CAR(f), env));
    }
    else PROTECT(b = CAR(args));

        /* It must be a closure! */

    if(TYPEOF(b) != CLOSXP) {
        b = deparse1(b, 1);
        errorcall(call, "%s is not a function\n", CHAR(STRING(b)[0]));
    }

        /* Do we expand ... ? */

    expdots = asLogical(CAR(CDDR(args)));
    if (expdots == NA_LOGICAL) {
        b = deparse1(CADDR(args), 1);
        errorcall(call, "%s is not a logical\n", CHAR(STRING(b)[0]));
    }

        /* Get the formals and match the actual args */

    formals = FORMALS(b);
    actuals = CDR(f);
    
    rlist = matchArgs(formals,actuals);
    
        /* Attach the argument names as tags */

    for(f=formals, b=rlist; b!=R_NilValue; b=CDR(b), f=CDR(f)) {
        TAG(b)=TAG(f);
    }

        /* Eliminate any unmatched formals */

    rlist = StripUnmatched(rlist);

        /* Handle the dots */

    PROTECT(rlist = ExpandDots(rlist, expdots));

    PROTECT(rval = allocSExp(LANGSXP));
    CAR(rval) = duplicate(CAR(CAR(CDR(args))));
    CDR(rval) = rlist;
    UNPROTECT(3);
    return rval;
}