The R Project SVN R

Rev

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

/*
 *  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"
#include "Fileio.h"

/* The size of vector initially allocated by scan */
#define SCAN_BLOCKSIZE      1000
/* The size of the console buffer */
#define CONSOLE_BUFFER_SIZE 1024

static char  ConsoleBuf[CONSOLE_BUFFER_SIZE];
static char *ConsoleBufp;
static int  ConsoleBufCnt;
static char  ConsolePrompt[32];

static void InitConsoleGetchar()
{
    ConsoleBufCnt = 0;
    ConsolePrompt[0] = '\0';
}

static int ConsoleGetchar()
{
    if (--ConsoleBufCnt < 0) {
        if (R_ReadConsole(ConsolePrompt, ConsoleBuf,
                CONSOLE_BUFFER_SIZE, 0) == 0) {
            R_ClearerrConsole();
            return R_EOF;
        }
        R_ParseCnt++;
        ConsoleBufp = ConsoleBuf;
        ConsoleBufCnt = strlen(ConsoleBuf);
        ConsoleBufCnt--;
    }
    return *ConsoleBufp++;
}


static int save = 0;
static int sepchar = 0;
static FILE *fp;
static int ttyflag;
static int quiet;
static SEXP NAstrings;

static int scanchar(void)
{
    if(save) {
        int c = save;
        save = 0;
        return c;
    }
    return (ttyflag) ? ConsoleGetchar() : R_fgetc(fp);
}

static void unscanchar(int c)
{
    save = c;
}

static int fillBuffer(char *buffer, SEXPTYPE type, int strip)
{
    char *bufp = buffer;
    int c, quote, filled;

    filled = 1;
    if(sepchar == 0) {
        while((c = scanchar()) == ' ' || c == '\t')
            ;
        if(c == '\n' || c == '\r' || c == R_EOF) {
            filled = c;
            goto donefill;
        }
        if(type == STRSXP && c == '\"' || c == '\'') {
            quote = c;
            while ((c = scanchar()) != R_EOF && c != quote) {
                if(bufp >= &buffer[MAXELTSIZE - 2])
                    continue;
                if (c == '\\') {
                    c = scanchar();
                    if(c == R_EOF) break;
                    else if (c == 'n') c = '\n';
                    else if (c == 'r') c = '\r';
                }
                *bufp++ = c;
            }
            c = scanchar();
            while(c==' ' || c=='\t')
                c=scanchar();
            if(c=='\n' || c=='\r' || c==R_EOF )
                filled=c;
            else
                unscanchar(c);
        }
        else {
            do {
                if(bufp >= &buffer[MAXELTSIZE - 2])
                    continue;
                *bufp++ = c;
            } while (!isspace(c = scanchar()) && c != R_EOF);
            while(c==' ' || c=='\t') 
                c=scanchar();
            if(c=='\n' || c=='\r' || c==R_EOF )
                filled=c;
            else
                unscanchar(c);
        }
    }
    else {
        while((c = scanchar()) != sepchar && c!= '\n' && c!='\r'
            && c != R_EOF ) 
        {
            /* eat white space */
            if( type != STRSXP )
                while(c==' ' || c=='\t') 
                    if((c=scanchar())== sepchar || c=='\n' ||
                    c=='\r' || c==R_EOF ) {
                    filled=c;
                    goto donefill;
                    }
            if(bufp >= &buffer[MAXELTSIZE - 2])
                continue;
            if( !strip || bufp != &buffer[0] || !isspace(c) )
                *bufp++ = c;
        } 
        filled=c;
    }
donefill:

    if( strip ) {
        while( isspace(*--bufp) )
            ;
        bufp++;
    }


    *bufp = '\0';
    return filled;
}

static int isNAstring(char *buf)
{
    int i;

    for(i=0; i<length(NAstrings) ; i++ ) 
        if (!strcmp(CHAR(STRING(NAstrings)[i]),buf))
            return 1;
    return 0;
}

static void expected(char *what, char *got)
{
    int c;

    if(ttyflag) {
        while((c = scanchar()) != R_EOF && c != '\n')
            ;
    }
    else fclose(fp);
    error("\"scan\" expected %s got \"%s\"\n", what, got);
}

static SEXP extractItem(char *buffer, SEXP ans, int i)
{
    char *endp;

    switch(TYPEOF(ans)) {
        case LGLSXP:
            if (isNAstring(buffer))
                LOGICAL(ans)[i] = NA_INTEGER;
            else
                LOGICAL(ans)[i] = StringTrue(buffer);
            break;
        case FACTSXP:
        case ORDSXP:
            if(!ttyflag) fclose(fp);
            error("can't scan factors (yet)\n");
        case INTSXP:
            if (isNAstring(buffer))
                INTEGER(ans)[i] = NA_INTEGER;
            else {
                INTEGER(ans)[i] = strtol(buffer, &endp, 10);
                if (*endp != '\0')
                    expected("an integer", buffer);
            }
            break;
        case REALSXP:
            if (isNAstring(buffer))
                REAL(ans)[i] = NA_REAL;
            else {
                REAL(ans)[i] = strtod(buffer, &endp);
                if (*endp != '\0')
                    expected("a real", buffer);
            }
            break;
        case STRSXP:
            if (isNAstring(buffer))
                STRING(ans)[i]= NA_STRING;
            else
                STRING(ans)[i] = mkChar(buffer);
            break;
    }
}

static SEXP scanVector(SEXPTYPE type, int maxitems, int maxlines, int flush, SEXP stripwhite)
{
    SEXP ans, bns;
    int blocksize, c, i, n, linesread, nprev,strip, bch;
    char buffer[MAXELTSIZE];

    if(maxitems > 0) blocksize = maxitems;
    else blocksize = SCAN_BLOCKSIZE;

    PROTECT(ans = allocVector(type, blocksize));

    nprev = 0; n = 0; linesread = 0; bch=1;

    if (ttyflag) sprintf(ConsolePrompt, "1: ");

    strip = asLogical(stripwhite);

    for(;;) {
        if (bch == R_EOF) {
            if(ttyflag) R_ClearerrConsole();
            break;
        }
        else if (bch == '\n') {
            linesread++;
            if (linesread == maxlines)
                break;
            if (ttyflag) {
                sprintf(ConsolePrompt, "%d: ", n + 1);
            }
            nprev = n;
        }
        if (n == blocksize) {
            /* enlarge the vector*/
            bns = ans;
            blocksize = 2 * blocksize;
            ans = allocVector(type, blocksize);
            UNPROTECT(1);
            PROTECT(ans);
            copyVector(ans, bns);
        }
        bch = fillBuffer(buffer, type, strip);
        if(nprev == n && strlen(buffer)==0 && (bch =='\n' ||
            bch == R_EOF) ) {
            if( ttyflag || bch == R_EOF )
                break;
        }
        else {
            extractItem(buffer, ans, n);
            if(++n == maxitems) {
                if(ttyflag && bch != '\n') {
                    while((c=scanchar()) != '\n')
                        ;
                }
                break;
            }
        }
        if( flush ) {
            while((c=scanchar()) != '\n')
                ;
            unscanchar(c);
        }
    }
    if(!quiet) REprintf("Read %d items\n", n);

    if (n == 0) {
        UNPROTECT(1);
        return allocVector(type,0);
    }
    if (n == maxitems) {
        UNPROTECT(1);
        return ans;
    }

    bns = allocVector(type, n);
    switch (type) {
    case LGLSXP:
    case INTSXP:
        for (i = 0; i < n; i++)
            INTEGER(bns)[i] = INTEGER(ans)[i];
        break;
    case REALSXP:
        for (i = 0; i < n; i++)
            REAL(bns)[i] = REAL(ans)[i];
        break;
    case STRSXP:
        for (i = 0; i < n; i++)
            STRING(bns)[i] = STRING(ans)[i];
        break;
    }
    UNPROTECT(1);
    return bns;
}

static SEXP scanFrame(SEXP what, int maxitems, int maxlines, int flush, SEXP stripwhite)
{
    SEXP a, ans, b, new, old, w;
    char buffer[MAXELTSIZE];
    int blksize, c, i, j, n, nc, linesread, colsread, strip, bch;
    int badline;

    nc = length(what);

    if(maxlines > 0) blksize = maxlines;
    else blksize = SCAN_BLOCKSIZE;

    PROTECT(ans = allocList(nc));
    a = ans;
    w = what;
    for (i = 0; i < nc; i++) {
        if (!isVector(CAR(w))) {
            if (!ttyflag) fclose(fp);
            error("\"scan\" invalid \"what=\" specified\n");
        }
        CAR(a) = allocVector(TYPEOF(CAR(w)), blksize);
        TAG(a) = TAG(w);
        a = CDR(a);
        w = CDR(w);
    }

    n = 0; linesread = 0; colsread=0;
    badline = 0;
    bch = 1;

    if (ttyflag) sprintf(ConsolePrompt, "1: ");

    strip=asLogical(stripwhite);

    a = ans;
    for(;;) {

        if (bch == R_EOF) {
            if(ttyflag) R_ClearerrConsole();
            goto done;
        }
        else if (bch == '\n') {
            linesread++;
            if( colsread != 0 && !badline )
                badline=linesread;
            if(maxitems > 0 && nc*linesread >= maxitems)
                goto done;
            if(maxlines > 0 && linesread == maxlines)
                goto done;
            if ( ttyflag)
                sprintf(ConsolePrompt, "%d: ", n + 1);
        }
        if (n == blksize && colsread == 0 ) {
            b = ans;
            blksize = 2 * blksize;
            for (i = 0; i < nc; i++) {
                old = CAR(b);
                new = allocVector(TYPEOF(old), blksize);
                copyVector(new, old);
                CAR(b) = new;
                b = CDR(b);
            }
        }
    
        bch=fillBuffer(buffer, TYPEOF(CAR(a)), strip);
        if(colsread == 0 && strlen(buffer)==0 && (bch =='\n' ||
            bch == R_EOF) ) {
            if( ttyflag || bch == R_EOF )
                break;
        }
        else {
            extractItem(buffer, CAR(a), n);
            a = CDR(a);
            colsread++;
            if( length(stripwhite) == length(what) ) 
                strip=LOGICAL(stripwhite)[colsread];
            /* increment n and reset i after filling a row */
            if( colsread == nc ) {
                n++;
                a = ans;
                colsread = 0;
                if( flush ) {
                    while(c != '\n' && c != R_EOF)
                        c=scanchar();
                    unscanchar(c);
                }
                if( length(stripwhite) == length(what) )
                    strip=LOGICAL(stripwhite)[0];
            }
        }
    }

done:
    if( badline ) 
        warning("line %d did not have %d elements\n",badline,nc);

    if( colsread != 0 ) {
        warning("number of items read is not a multiple of the number of columns\n");
        a=nthcdr(ans, colsread);
        buffer[0]='\0'; /* this is an NA */
        while (a != R_NilValue ) {
            extractItem(buffer, CAR(a), n);
            a = CDR(a);
        }
        n++;
    }
    if(!quiet) REprintf("Read %d lines\n", n);

    /*
    if (n == maxitems ) {
        UNPROTECT(1);
        return ans;
    }
    */

    a = ans;
    for (i = 0; i < nc; i++) {
        old = CAR(a);
        new = allocVector(TYPEOF(old), n);
        switch (TYPEOF(old)) {
        case LGLSXP:
        case INTSXP:
            for (j = 0; j < n; j++)
                INTEGER(new)[j] = INTEGER(old)[j];
            break;
        case REALSXP:
            for (j = 0; j < n; j++)
                REAL(new)[j] = REAL(old)[j];
            break;
        case STRSXP:
            for (j = 0; j < n; j++) 
                STRING(new)[j] = STRING(old)[j];
            break;
        }
        CAR(a) = new;
        a = CDR(a);
    }
    UNPROTECT(1);
    return ans;
}

SEXP do_scan(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans, file, sep, what, stripwhite;
    int i, c, nlines, nmax, nskip, flush;
    char *filename;

    checkArity(op, args);
    file = CAR(args); args = CDR(args);
    what = CAR(args); args = CDR(args);
    nmax = asInteger(CAR(args)); args = CDR(args);
    sep = CAR(args); args = CDR(args);
    nskip = asInteger(CAR(args)); args = CDR(args);
    nlines = asInteger(CAR(args)); args = CDR(args);
    NAstrings = CAR(args); args = CDR(args);
    flush = asLogical(CAR(args)); args = CDR(args); 
    stripwhite = CAR(args); args = CDR(args);
    quiet = asLogical(CAR(args));
    if(quiet == NA_LOGICAL) quiet = 0;

    if (nskip < 0 || nskip == NA_INTEGER) nskip = 0;
    if (nlines < 0 || nlines == NA_INTEGER) nlines = 0;
    if (nmax < 0 || nmax == NA_INTEGER) nmax = 0;

    if(isString(sep) || isNull(sep)) {
        if(LENGTH(sep) == 0) sepchar = 0;
        else sepchar = CHAR(STRING(sep)[0])[0];
    }
    else errorcall(call, "invalid sep value\n");

    if( TYPEOF(stripwhite) != LGLSXP )
        errorcall(call, "invalid strip.white value\n");
    if( length(stripwhite) != 1 && length(stripwhite) != length(what) )
        errorcall(call, "invalid strip.white length\n");

    if( TYPEOF(NAstrings) != STRSXP )
                errorcall(call, "invalid na.strings value\n");

    if (isNull(file))
        filename = NULL;
    else if (isString(file)) {
        filename = CHAR(*STRING(file));
        if (strlen(filename) == 0)
            filename = NULL;
    }
    else errorcall(call, "\"scan\" file name required\n");

    if (filename) {
        ttyflag = 0;
        filename = R_ExpandFileName(filename);
        if ((fp = R_fopen(filename, "r")) == NULL)
            error("\"scan\" can't open file\n");
        for (i = 0; i < nskip; i++)
            while ((c = scanchar()) != '\n' && c != R_EOF);
    }
    else ttyflag = 1;

    save = 0;

    switch (TYPEOF(what)) {
    case LGLSXP:
    case FACTSXP:
    case ORDSXP:
    case INTSXP:
    case REALSXP:
    case STRSXP:
        ans = scanVector(TYPEOF(what), nmax, nlines, flush, stripwhite);
        break;
    case LISTSXP:
        ans = scanFrame(what, nmax, nlines, flush, stripwhite);
        break;
    default:
        if (!ttyflag) fclose(fp);
        error("\"scan\" invalid \"what=\" specified\n");
    }
    if (!ttyflag)
        fclose(fp);
    return ans;
}

SEXP do_countfields(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP ans, file, sep, bns;
    int nfields, nskip, i, c;
    int blocksize, nlines;
    char *filename;

    checkArity(op, args);

    file = CAR(args); args = CDR(args);
    sep = CAR(args); args = CDR(args);
    nskip = asInteger(CAR(args)); 

    if (nskip < 0 || nskip == NA_INTEGER) nskip = 0;

    if(isString(sep) || isNull(sep)) {
        if(LENGTH(sep) == 0) sepchar = 0;
        else sepchar = CHAR(STRING(sep)[0])[0];
    }
    else errorcall(call, "invalid sep value\n");

    if (isString(file)) {
        filename = CHAR(*STRING(file));
        if (strlen(filename) == 0)
            filename = NULL;
    }
    else 
        filename = NULL;

    if(filename == NULL)
        errorcall(call, "\"scan\" file name required\n");

    if (filename) {
        ttyflag = 0;
        filename = R_ExpandFileName(filename);
        if ((fp = R_fopen(filename, "r")) == NULL)
            error("\"scan\" can't open file\n");
        for (i = 0; i < nskip; i++)
            while ((c = scanchar()) != '\n' && c != R_EOF);
    }

    blocksize = SCAN_BLOCKSIZE;
    PROTECT(ans = allocVector(INTSXP, blocksize));
    nlines=0;
    nfields=0;

    for(;;) {
        c = scanchar();
        if(c == R_EOF)  {
            if(nfields != 0) 
                INTEGER(ans)[nlines] = nfields;
            else nlines--;
            goto donecf;
        }
        else if(c == '\n') {
            if(nfields) {
                INTEGER(ans)[nlines] = nfields;
                nlines++;
                nfields = 0;
            }
            if(nlines == blocksize) {
                bns = ans;
                blocksize = 2 * blocksize;
                ans = allocVector(INTSXP, blocksize);
                UNPROTECT(1);
                PROTECT(ans);
                copyVector(ans, bns);
            }
            continue;
        }
        else if(sepchar) {
            if(c == sepchar)
                nfields++;
            else if(nfields == 0)
                nfields++;
        }
        else if(!isspace(c)) {
            if(c == '"' || c == '\'') {
                int quote = c;
                while((c=scanchar()) != quote) {
                    if(c == R_EOF || c == '\n') {
                        fclose(fp);
                        errorcall(call, "string terminated by newline or EOF\n");
                    }
                }
            }
            else {
                while(!isspace(c=scanchar()) && c != R_EOF )
                    ;
                if (c==R_EOF) c='\n';
                unscanchar(c);
            }
            nfields++;
        }

    }
donecf:
    fclose(fp);

    if (nlines < 0) {
        UNPROTECT(1);
        return R_NilValue;
    }
    if (nlines == blocksize) {
        UNPROTECT(1);
        return ans;
    }

    bns = allocVector(INTSXP, nlines+1);
    for (i = 0; i <= nlines; i++)
        INTEGER(bns)[i] = INTEGER(ans)[i];
    UNPROTECT(1);
    return bns;
}

/*
 *  frame.convert(char, na.strings, as.is)
 *
 *  This is a horrible hack which is used in read.table to
 *  take a character variable, if possible to convert it
 *  to a numeric variable.  If this is not possible, the
 *  result is a character string if as.is==TRUE or a factor
 *  if as.is==FALSE.
 */

SEXP do_typecvt(SEXP call, SEXP op, SEXP args, SEXP env)
{
        SEXP cvec, a, rval, dup, levs, dims, names;
        int i, j, len, numeric, asIs;
    char *endp, *tmp;

        checkArity(op,args);

        if(!isString(CAR(args)))
                errorcall(call,"the first argument must be of mode character\n");

    NAstrings = CADR(args);
    if( TYPEOF(NAstrings) != STRSXP )
                errorcall(call, "invalid na.strings value\n");

    asIs = asLogical(CADDR(args));
    if(asIs == NA_LOGICAL) asIs = 0;

    cvec = CAR(args);
    len=length(cvec);

    numeric = 1;

        /* save the dim/dimname attributes */

    PROTECT(dims = getAttrib(cvec, R_DimSymbol));
    if (isArray(cvec))
        PROTECT(names = getAttrib(cvec, R_DimNamesSymbol));
    else
        PROTECT(names = getAttrib(cvec, R_NamesSymbol));

    PROTECT(rval = allocVector(REALSXP, length(cvec)));
    for( i=0 ; i<len ; i++ ) {
        tmp=CHAR(STRING(cvec)[i]);
        if( isNAstring(tmp) )
            REAL(rval)[i] = NA_REAL;
        else {
            if( strlen(tmp) != 0 ) {
                REAL(rval)[i] = strtod(tmp, &endp);
                if( *endp != '\0') {
                    numeric = 0;
                    break;
                }
            }
            else errorcall(call,"null string encountered\n");
        }
    }
    if(!numeric) {
        if(asIs) {
            rval = cvec;
        }
        else {
            PROTECT(rval = allocVector(FACTSXP,length(cvec)));
            PROTECT(dup = duplicated(cvec));
            j = 0;
            for( i=0 ; i<len ; i++ )
                if (LOGICAL(dup)[i] == 0 && !isNAstring(CHAR(STRING(cvec)[i])) )
                    j++;
            LEVELS(rval) = j;
            PROTECT(levs = allocVector(STRSXP,j));
            j=0;
            for( i=0 ; i<len ; i++ ) 
                if(LOGICAL(dup)[i] == 0 && !isNAstring(CHAR(STRING(cvec)[i])) )
                    STRING(levs)[j++] = STRING(cvec)[i];
    
            /* put the levels in lexicographic order */

            sortVector(levs);
    
            PROTECT(a=match(levs, cvec, NA_INTEGER));   
            for (i = 0; i < len; i++) 
                FACTOR(rval)[i]=INTEGER(a)[i];
    
            setAttrib(rval, R_LevelsSymbol, levs);
            PROTECT(a = allocVector(STRSXP, 1));
            STRING(a)[0] = mkChar("factor");
            setAttrib(rval, R_ClassSymbol, a);
            UNPROTECT(5);
        }
    }
    setAttrib(rval, R_DimSymbol, dims);
    if (isArray(cvec))
        setAttrib(rval, R_DimNamesSymbol, names);
    else
        setAttrib(rval, R_NamesSymbol, names);
    UNPROTECT(3);
    return rval;
}

SEXP do_readln(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    int c;
    char buffer[MAXELTSIZE], *bufp = buffer;
    SEXP ans;

    checkArity(op,args);

    /* skip white space */
    while( (c= ConsoleGetchar()) == ' ' || c=='\t');
    if(c != '\n' && c != R_EOF) {
        *bufp++ = c;
        while ((c = ConsoleGetchar())!= '\n' && c != R_EOF ) {
            if(bufp >= &buffer[MAXELTSIZE - 2])
                continue;
            *bufp++ = c;
        }
    }
    /* now strip white space off the end as well */
    while( isspace(*--bufp) )
        ;
    *++bufp = '\0';
    PROTECT(ans=allocVector(STRSXP,1));
    STRING(ans)[0]=mkChar(buffer);
    UNPROTECT(1);
    return ans;
}

SEXP do_menu(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    int c,j;
    double first;
        char buffer[MAXELTSIZE], *bufp = buffer;
        SEXP ans;

    checkArity(op,args);

    if(!isString(CAR(args)))
        errorcall(call,"wrong argument\n");

    while((c=ConsoleGetchar()) != '\n' && c != R_EOF) {
        if(bufp >= &buffer[MAXELTSIZE - 2])
            continue;
        *bufp++ = c;
    }
    *bufp++='\0';
    bufp=buffer;
    while(isspace(*bufp)) bufp++;
    first=LENGTH(CAR(args))+1;
    if(isdigit(*bufp)) 
        first=strtod(buffer,NULL);
    else {
        for(j=0 ; j< LENGTH(CAR(args)) ; j++ ) {
            if(streql(CHAR(STRING(CAR(args))[j]),buffer) ){
                first=j+1;
                break;
            }
        }
    }
    ans=allocVector(INTSXP,1);
    INTEGER(ans)[0]=first;
    return ans;
}