The R Project SVN R

Rev

Rev 1895 | Rev 3076 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed 

/*
 *  R : A Computer Language 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 Pulic 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"

/* Functions to perform analogues of the standard C string library. */
/* Most are vectorized */

SEXP do_nchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP d, s, x;
    int i, len;

    checkArity(op, args);
    PROTECT(x = coerceVector(CAR(args), STRSXP));
    if (!isString(x))
    error("invalid type, nchar requires a character vector\n");
    len = LENGTH(x);
    PROTECT(s = allocVector(INTSXP, len));
    for (i = 0; i < len; i++)
    INTEGER(s)[i] = strlen(CHAR(STRING(x)[i]));
    if ((d = getAttrib(x, R_DimSymbol)) != R_NilValue)
    setAttrib(s, R_DimSymbol, d);
    if ((d = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
    setAttrib(s, R_DimNamesSymbol, d);
    UNPROTECT(2);
    return s;
}


static void substr(char *buf, char *str, int sa, int so)
{
    int i;
    str += (sa - 1);
    for (i = 0; i <= (so - sa); i++)
    *buf++ = *str++;
    *buf = '\0';
}

SEXP do_substr(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP s, x, sa, so;
    int i, len, start, stop, slen, k, l;
    char buff[MAXELTSIZE];

    checkArity(op, args);
    x = CAR(args);
    sa = CADR(args);
    so = CAR(CDDR(args));

    if (!isString(x) || !isInteger(sa) || !isInteger(so))
    error("invalid type to substr\n");

    len = LENGTH(x);
    k = LENGTH(sa);
    l = LENGTH(so);
    PROTECT(s = allocVector(STRSXP, len));
    for (i = 0; i < len; i++) {
    start = INTEGER(sa)[i % k];
    stop = INTEGER(so)[i % l];
    slen = strlen(CHAR(STRING(x)[i]));
    if (start < 1)
        start = 1;
    if (start > stop || start > slen) {
        buff[0]='\0';
        STRING(s)[i] = mkChar(buff);
    }
    else {
        if (stop > slen)
        stop = slen;
        if (stop > MAXELTSIZE) {
        stop = MAXELTSIZE;
        warning("a string was truncated in substr\n");
        }
        substr(buff, CHAR(STRING(x)[i]), start, stop);
        STRING(s)[i] = mkChar(buff);
    }
    }
    UNPROTECT(1);
    return s;
}


/* strsplit is going to split the strings in the first argument into */
/* tokens depending on the second argument. The characters of the second */
/* argument are used to split the first argument.  A list of vectors is */
/* returned of length equal to the input vector x, each element of the */
/* list is the collection of splits for the corresponding element of x. */

SEXP do_strsplit(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP s, t, tok, x;
    int i, j, len, tlen, ntok;
    char buff[MAXELTSIZE], *pt, *split = "";

    checkArity(op, args);
    x = CAR(args);
    tok = CADR(args);
    if (!isString(x) || !isString(tok))
    error("invalid type to strsplit\n");
    len = LENGTH(x);
    tlen = LENGTH(tok);
    PROTECT(s = allocVector(VECSXP, len));
    for (i = 0; i < len; i++) {
    /* find out how many splits there will be */
    strcpy(buff, CHAR(STRING(x)[i]));
    if (tlen > 0) {
        split = CHAR(STRING(tok)[i % tlen]);
        ntok = 0;
        if (strtok(buff, split) != NULL) {
        do {
            ntok++;
        }
        while (strtok(NULL, split) != NULL);
        }
    }
    else ntok = strlen(buff);
    PROTECT(t = allocVector(STRSXP, ntok));
    if (tlen > 0) {
        strcpy(buff, CHAR(STRING(x)[i]));
        pt = strtok(buff, split);
        for (j = 0; j < ntok; j++) {
        STRING(t)[j] = mkChar(pt);
        pt = strtok(NULL, split);
        }
    }
    else {
        char bf[2];
        bf[1]='\0';
        for (j = 0; j < ntok; j++) {
        bf[0]=buff[j];
        STRING(t)[j] = mkChar(bf);
        }
    }
    UNPROTECT(1);
    VECTOR(s)[i] = t;
    }
    UNPROTECT(1);
    return s;
}


/* Abbreviate long names in the S-designated fashion; first spaces then */
/* lower case vowels; then lower case consonants; then upper case letters */
/* special characters.  Letters are dropped from the end of words and at */
/* least one letter is retained from each word.  If use.classes is FALSE */
/* then the only differentiation is between white space and letters.  If */
/* unique abbreviations are not produced letters are added until the */
/* results are unique (duplicated names are removed prior to entry). */
/* names, minlength, use.classes, dot */

static SEXP stripchars(SEXP inchar, int minlen)
{
    int i, j, nspace = 0, upper;
    char buff1[MAXELTSIZE];

    strcpy(buff1, CHAR(inchar));
    upper = strlen(buff1)-1;

    /*remove beginning blanks */

    j = 0;
    for (i = 0 ; i < upper ; i++)
    if (isspace(buff1[i]))
        j++;
    else
        break;

    strcpy(buff1, &buff1[j]);
    upper = strlen(buff1) - 1;

    if (strlen(buff1) < minlen)
    goto donesc;

    for (i = upper; i > 0; i--) {
    if (isspace(buff1[i]))
        nspace++;
    /*strcpy(buff1[i],buff1[i+1]);*/
    if (strlen(buff1) - nspace <= minlen)
        goto donesc;
    }

    upper = strlen(buff1) -1;

    for (i = upper; i > 0; i--) {
    if ((buff1[i] == 'a' || buff1[i] == 'e' || buff1[i] == 'i' ||
         buff1[i] == 'o' || buff1[i] == 'u')) {
        if (!(isspace(buff1[i - 1]) && isspace(buff1[i + 1])))
        strcpy(&buff1[i], &buff1[i + 1]);
    }
    if (strlen(buff1) - nspace <= minlen)
        goto donesc;
    }

    upper = strlen(buff1) - 1;

    for (i = upper; i >= 0; i--) {
    if (islower(buff1[i])) {
        if (!(isspace(buff1[i - 1]) && isspace(buff1[i + 1])))
        strcpy(&buff1[i], &buff1[i + 1]);
    }
    if (strlen(buff1) - nspace <= minlen)
        goto donesc;
    }

    /* all else has failed so we use brute force */

    upper = strlen(buff1);
    for (i = upper; i > 0; i--) {
    if (!(isspace(buff1[i - 1]) && isspace(buff1[i + 1])))
        strcpy(&buff1[i], &buff1[i + 1]);
    if (strlen(buff1) - nspace <= minlen)
        goto donesc;
    }

 donesc:

    upper = strlen(buff1);
    if (upper > minlen)
    for (i = upper - 1; i > 0; i--)
        if (isspace(buff1[i]))
        strcpy(&buff1[i], &buff1[i + 1]);

    return(mkChar(buff1));
}


SEXP do_abbrev(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans;
    int i, len, minlen, uclass;

    checkArity(op,args);

    if (!isString(CAR(args)))
    errorcall(call, "the first argument must be a string\n");
    len = length(CAR(args));

    PROTECT(ans = allocVector(STRSXP, len));
    minlen = asInteger(CADR(args));
    uclass = asLogical(CAR(CDDR(args)));
    for (i = 0 ; i < len ; i++)
    STRING(ans)[i] = stripchars(STRING(CAR(args))[i], minlen);

    UNPROTECT(1);
    return(ans);
}


SEXP do_makenames(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP arg, ans;
    int i, l, n;
    char *p;

    checkArity(op ,args);
    arg = CAR(args);
    if (!isString(arg))
    errorcall(call, "non-character names\n");
    n = length(arg);
    PROTECT(ans = allocVector(STRSXP, n));
    for (i = 0 ; i < n ; i++) {
    l = strlen(CHAR(STRING(arg)[i]));
    if (isalpha(CHAR(STRING(arg)[i])[0])) {
        STRING(ans)[i] = allocString(l);
        strcpy(CHAR(STRING(ans)[i]), CHAR(STRING(arg)[i]));
    }
    else {
        STRING(ans)[i] = allocString(l + 1);
        strcpy(CHAR(STRING(ans)[i]), "X");
        strcat(CHAR(STRING(ans)[i]), CHAR(STRING(arg)[i]));
    }
    p = CHAR(STRING(ans)[i]);
    while (*p) {
        if (!isalnum(*p) && *p != '.')
        *p = '.';
        p++;
    }
    }
    UNPROTECT(1);
    return ans;
}

#ifdef HAVE_REGCOMP
#include <sys/types.h>
#include <regex.h>
#endif

SEXP do_grep(SEXP call, SEXP op, SEXP args, SEXP env)
{
#ifdef HAVE_REGCOMP
    SEXP pat, vec, ind, ans;
    regex_t reg;
    int i, j, n, nmatches;
    int igcase_opt, extended_opt, value_opt, eflags;

    checkArity(op, args);
    pat = CAR(args); args = CDR(args);
    vec = CAR(args); args = CDR(args);
    igcase_opt = asLogical(CAR(args)); args = CDR(args);
    extended_opt = asLogical(CAR(args)); args = CDR(args);
    value_opt = asLogical(CAR(args)); args = CDR(args);
    if (igcase_opt == NA_INTEGER) igcase_opt = 0;
    if (extended_opt == NA_INTEGER) extended_opt = 1;
    if (value_opt == NA_INTEGER) value_opt = 0;

    if (!isString(pat) || length(pat) < 1 || !isString(vec))
    errorcall(call, "invalid argument\n");

    eflags = 0;

    if (extended_opt) eflags = eflags | REG_EXTENDED;
    if (igcase_opt) eflags = eflags | REG_ICASE;

    if (regcomp(&reg, CHAR(STRING(pat)[0]), eflags))
    errorcall(call, "invalid regular expression\n");

    n = length(vec);
    ind = allocVector(LGLSXP, n);
    nmatches = 0;
    for (i = 0 ; i < n ; i++) {
    if (regexec(&reg, CHAR(STRING(vec)[i]), 0, NULL, 0) == 0) {
        INTEGER(ind)[i] = 1;
        nmatches++;
    }
    else INTEGER(ind)[i] = 0;
    }
    regfree(&reg);
    PROTECT(ind);
    if (value_opt) {
    ans = allocVector(STRSXP, nmatches);
    j = 0;
    for (i = 0 ; i < n ; i++)
        if (INTEGER(ind)[i])
        STRING(ans)[j++] = STRING(vec)[i];
    }
    else {
    ans = allocVector(INTSXP, nmatches);
    j = 0;
    for (i = 0 ; i < n ; i++)
        if (INTEGER(ind)[i]) INTEGER(ans)[j++] = i + 1;
    }
    UNPROTECT(1);
    return ans;
#else
    errorcall(call, "POSIX regular expressions not available\n");
#endif
}

#ifdef HAVE_REGCOMP

/* The following R functions do substitution for regular expressions, */
/* either once or globally.  The functions are loosely patterned on the */
/* "sub" and "gsub" in "nawk". */

static int length_adj(char *repl, regmatch_t *regmatch, int nsubexpr)
{
    int k, n;
    char *p = repl;
    n = strlen(repl) - (regmatch[0].rm_eo - regmatch[0].rm_so);
    while (*p) {
    if (*p == '\\') {
        if ('1' <= p[1] && p[1] <= '9') {
        k = p[1] - '0';
        if (k > nsubexpr)
            error("invalid backreference in regular expression\n");
        n += (regmatch[k].rm_eo - regmatch[k].rm_so) - 2;
        p++;
        }
        else if (p[1] == 0) {
                /* can't escape the final '\0' */
        n -= 1;
        }
        else {
        n -= 1;
        p++;
        }
    }
    p++;
    }
    return n;
}

static char *string_adj(char *target, char *orig, char *repl,
            regmatch_t *regmatch, int nsubexpr)
{
    int i, k;
    char *p = repl, *t = target;
    while (*p) {
    if (*p == '\\') {
        if ('1' <= p[1] && p[1] <= '9') {
        k = p[1] - '0';
        for (i = regmatch[k].rm_so ; i < regmatch[k].rm_eo ; i++)
            *t++ = orig[i];
        p += 2;
        }
        else if (p[1] == 0) {
        p += 1;
        }
        else {
        p += 1;
        *t++ = *p++;
        }
    }
    else *t++ = *p++;
    }
    return t;
}

#endif

SEXP do_gsub(SEXP call, SEXP op, SEXP args, SEXP env)
{
#ifdef HAVE_REGCOMP
    SEXP pat, rep, vec, ans;
    regex_t reg;
    regmatch_t regmatch[10];
    int i, j, n, ns, nmatch, offset;
    int global, igcase_opt, extended_opt, eflags;
    char *s, *t, *u;

    checkArity(op, args);

    global = PRIMVAL(op);

    pat = CAR(args); args = CDR(args);
    rep = CAR(args); args = CDR(args);
    vec = CAR(args); args = CDR(args);
    igcase_opt = asLogical(CAR(args)); args = CDR(args);
    extended_opt = asLogical(CAR(args)); args = CDR(args);
    if (igcase_opt == NA_INTEGER) igcase_opt = 0;
    if (extended_opt == NA_INTEGER) extended_opt = 1;

    if (!isString(pat) || length(pat) < 1 ||
       !isString(rep) || length(rep) < 1 ||
       !isString(vec))
    errorcall(call, "invalid argument\n");

    eflags = 0;
    if (extended_opt) eflags = eflags | REG_EXTENDED;
    if (igcase_opt) eflags = eflags | REG_ICASE;

    if (regcomp(&reg, CHAR(STRING(pat)[0]), eflags))
    errorcall(call, "invalid regular expression\n");

    n = length(vec);
    PROTECT(ans = allocVector(STRSXP, n));

    for (i = 0 ; i < n ; i++) {
    offset = 0;
    nmatch = 0;
    s = CHAR(STRING(vec)[i]);
    t = CHAR(STRING(rep)[0]);
    ns = strlen(s);
    while (regexec(&reg, &s[offset], 10, regmatch, 0) == 0) {
        nmatch += 1;
        ns += length_adj(t, regmatch, reg.re_nsub);
        offset += regmatch[0].rm_eo;
        if (s[offset] == '\0' || !global) break;
    }
    if (nmatch == 0) STRING(ans)[i] = STRING(vec)[i];
    else {
        STRING(ans)[i] = allocString(ns);
        offset = 0;
        nmatch = 0;
        s = CHAR(STRING(vec)[i]);
        t = CHAR(STRING(rep)[0]);
        u = CHAR(STRING(ans)[i]);
        ns = strlen(s);
        while (regexec(&reg, &s[offset], 10, regmatch, 0) == 0) {
        for (j = 0; j < regmatch[0].rm_so ; j++)
            *u++ = s[offset+j];
        u = string_adj(u, &s[offset], t, regmatch, reg.re_nsub);
        offset += regmatch[0].rm_eo;
        if (s[offset] == '\0' || !global) break;
        }
        for (j = offset ; s[j] ; j++)
        *u++ = s[j];
        *u = '\0';
    }
    }
    regfree(&reg);
    UNPROTECT(1);
    return ans;
#else
    errorcall(call, "POSIX regular expressions not available\n");
#endif
}