datalist.src

没有说明

/*
** datalist.src
** (C) Copyright 1991-1998 by Aptech Systems, Inc.
** All Rights Reserved Worldwide.
**
** This Software Product is PROPRIETARY SOURCE CODE OF APTECH
** SYSTEMS, INC.    This File Header must accompany all files using
** any portion, in whole or in part, of this Source Code.   In
** addition, the right to create such files is strictly limited by
** Section 2.A. of the GAUSS Applications License Agreement
** accompanying this Software Product.
**
** If you wish to distribute any portion of the proprietary Source
** Code, in whole or in part, you must first obtain written
** permission from Aptech Systems.
**
**> datalist
**
**  Purpose:    List a GAUSS data set.
**
**  Format:     datalist dataset var1 var2 ... ;
**
**              dataset    name of file to be selected from.
**
**              vars       if none are listed,  all variables will be printed.
**
**  Globals:    __range    range of records in the data set to list.  The
**                         default is the whole data set.
**
**              __miss     deletion of missing data.
**
**                            1   delete cases containing missing data
**                            0   missing data will be displayed
**
**              __prec    the number of places to the right of the decimal
**                        point in the listing.
**
**  Example:    datalist freq age sex pay;
**
**           This command will display three variables age, sex, and pay
**           of the data set freq.dat.
*/

#include gauss.ext

keyword datalist(strng);

    local dataset, varnm, str, temp, fp, np;

    if strng $== "";

    newfile:

        print "Data set: ";;
#ifOS2WIN
        print /flush "";;
#endif
        strng = cons;
        if strng $== "";
            retp;
        endif;
        print;
    newvars:

        print "Variables to list: ";;
#ifOS2WIN
        print /flush "";;
#endif
        temp = cons;
        print;
        if temp $== "?";
            open fp = ^strng;
            if fp == -1;
                print "'" strng "'" " not found";
                goto newfile;
            else;
                fp = close(fp);
                print $getname(strng)';
                goto newvars;
            endif;
        endif;
        strng = strng $+ " " $+ temp;
    endif;

    str = chrs(missrv(miss(miss(miss(vals(strng),10),13),44),32));

    { dataset,str } = token(str);
    np = 0;
    varnm = { };

    do while strlen(str);
        { temp,str } = token(str);
        if strsect(temp,1,1) $== "/";
            if temp $== "/np";
                np = 1;
            elseif temp $== "/";
                { temp,str } = token(str);
                if temp $== np;
                    np = 1;
                endif;
            endif;
        else;
            varnm = varnm|temp;
        endif;
    endo;

    if scalerr(varnm);
        varnm = 0;
    endif;

    call _dtlist(dataset, varnm, __prec, np);
    retp;
endp;

#ifOS2WIN

proc (0) = _dtlist(infile, vname, dgt, np);

    local colper,fin,flag,inindx,invar,k,ky, nrow,ncol,dcol,dflt, vtype,nr,
        start,outlbl,qq,rlbl,tx,x,nm,rmax,dfltc, csrold,dlstpau,dlstdgt,
        lastobs,counter,rpos,cstrt;
    cstrt = 1;
    csrold = csrtype(0);
    clear dlstpau;
    fin = -1;
    flag = 1;
    dflt = 27;
    nrow = 20;

    dcol = 65;
    dfltc = "Esc";
    cls;

    infile = "" $+ infile;
    open fin = ^infile;
    if fin == -1;
        errorlog "ERROR:  Can't open file " $+ infile $+ ".";
        ndpclex;
        print;
        call csrtype(csrold);
        retp;
    endif;
    if vname == 0;
        invar = getname(infile);
    else;
        invar = vname;
    endif;
    { nr,start,counter,lastobs } = _rngchk(infile,__range);

    rmax = rowsf(fin);
    if rmax > lastobs;
        rmax = lastobs;
    endif;

    dlstdgt = dgt;
    if np == 0;
        dlstpau = 1;
        nr = nrow;
    else;
        dlstpau = 0;
    endif;

    { nm, inindx } = indices(infile, invar);
    { outlbl,vtype } = nametype(nm,__vtype);

    call seekr(fin,start);
    do while 1;

        x = readr(fin,nr);
        x = x[.,inindx];
        counter = counter+rows(x);
        if counter > lastobs;
            x = trimr(x, 0, counter-lastobs);
        endif;
        if __miss == 1;
            x = packr(x);
        endif;
        if scalmiss(x);
            continue;       /* no observations returned */
        endif;

        if flag;
            if vtype == 0;
                colper = 10;
            else;
                tx = packr(miss(vtype,0)~x')';
                k = 2+strlen(ftos( maxc(maxc(tx)),"#*.*lG",1,dlstdgt));
                clear tx;
                colper = maxc(k|10);        /* columns per number */
                if colper > dcol;
                    colper = dcol;
                endif;
            endif;
            ncol = trunc(dcol/colper);      /* number of columns */
            flag = 0;
        endif;

        rlbl = 0$+"#"$+ftocv(seqa(start,1,rows(x)),1,0);
        { qq,cstrt } = _dtwrt(upper(infile),x,rlbl,outlbl,vtype,dlstpau,
            ncol, colper,dlstdgt,cstrt,dflt,dfltc);
        if qq == 1;
            goto quit;
        endif;
        print;
        if dlstpau;

            if qq > 1;
                ky = qq;
                goto havekey;
            endif;

        skipkey:

            ky = keyw;

            if ky == 13;
                ky = dflt;
            endif;

        havekey:

            if ky == 27;    /* ESC */
                goto quit;

            elseif ky == 1081;      /* PGDN */
                dflt = 1081;
                dfltc = "PgDn";
                rpos = seekr(fin,-1);
                if rpos + nrow == rmax;
                    call seekr(fin,rpos-nrow);
                    counter = seekr(fin,-1)-1;
                elseif rpos == rmax + 1;
                    call seekr(fin,rpos-rows(x));
                    counter = counter - rows(x);
                elseif rpos > rmax;
                    call seekr(fin,rmax-rows(x));
                    counter = counter - rows(x);
                elseif rpos + nrow > rmax;
                    call seekr(fin,rmax-rows(x)+1);
                    counter = seekr(fin,-1)-1;
                endif;

            elseif ky == 1073;      /* PGUP */
                dflt = 1073;
                dfltc = "PgUp";
                rpos = seekr(fin,-1);
                if rpos - 2*nrow < 1;
                    call seekr(fin,1);
                else;
                    call seekr(fin,rpos-2*nrow);
                endif;
                counter = seekr(fin,-1)-1;

            elseif ky == 1072;      /* CURSOR_UP */
                dflt = 1072;
                dfltc "\30";

                rpos = seekr(fin,-1);
                if rpos - nrow - 1 < 1;
                    call seekr(fin,1);
                else;
                    call seekr(fin,rpos-nrow-1);
                endif;
                counter = seekr(fin,-1)-1;

            elseif ky == 1080;      /* CURSOR_DN */
                dflt = 1080;
                dfltc = "\31";

                rpos = seekr(fin,-1);
                if rmax < nrow;
                    call seekr(fin,1);
                elseif rpos+1 > rmax;
                    call seekr(fin,rmax-nrow+1);
                elseif not eof(fin);
                    call seekr(fin,rpos-nrow+1);
                else;
                    call seekr(fin,rpos-nrow);
                endif;
                counter = seekr(fin,-1)-1;

            elseif ky == 1071;      /* HOME */
                dflt = 1071;
                dfltc = "Home";
                call seekr(fin,1);
                counter = 0;

            elseif ky == 1079;      /* END */
                dflt = 1079;
                dfltc = "End";
                if rmax < nrow;
                    call seekr(fin,1);
                    counter = 0;
                else;
                    call seekr(fin,rmax-nrow+1);
                    counter = seekr(fin,-1)-1;
                endif;

            else;
                goto skipkey;
            endif;
            cls;

        endif;
        start = counter+1;
    endo;

quit:

    if fin > 0;
        fin = close(fin);
    endif;
    ndpclex;
    call csrtype(csrold);
    retp;

endp;

proc (2) = _dtwrt(lbl,mat,rlbl,clbl,ctyp,pause,ncol, colper,dlstdgt,cstrt,
    dflt,dfltc);

    local lcnprt,cnprt,cslct,fmt,ky,msk,pcsn,oldnfmt,oldcfmt,klist;

    /* Home,End, PgDn,PgUp,down,up, rt, lft, ^rt, ^lft,? */
    klist = { 1071,1079,1081,1073,1080,1072,1075,1077,1115,1116,63 };

    pcsn = dlstdgt;
    cnprt = minc(ncol|cols(mat));
    do while 1;

        /* display the title */
        if strindx(".dat",lower(lbl),1);
            _cntrprt(1,lower(getpath(lower(lbl))),vals("_"));
        else;
            _cntrprt(1,lower(getpath(lower(lbl $+ ".dat"))),vals("_"));
        endif;
        print;

        /* display the data matrix */
        cslct = seqa(cstrt,1,cnprt);
        msk = zeros(1,cnprt+1);
        fmt = "-*.*s"~colper~colper|((zeros(cnprt,1)$+("*.*s"))~
            (zeros(cnprt,1) +(colper~9)));
        if clbl[1,1] ne 0;
            print;
            call printfm(""~clbl[cslct,.]',msk,fmt);
        endif;
        msk = ctyp[cslct];
        print;
        msk = 0~msk';
        oldnfmt = formatnv("#*.*lG"~colper~pcsn);
        oldcfmt = formatcv("*.*s"~colper~colper);
        call printfmt(rlbl~mat[.,cslct],msk);
        if rows(mat) == 1;
            print;
        endif;
        cstrt = cstrt+minc(ncol|cols(mat));
        lcnprt = cnprt;
        cnprt = minc(cnprt|(cols(mat)-cstrt+1));

    skipkey:

        if pause;
            _cntrprt(24,"",vals("_"));
            print;
            print;
            print "PgDn  PgUp  Home  End  \17  \16  \30  \31  Ctrl-\17" "  "\
                "Ctrl-\16  ?  Esc  [" dfltc "] ";;
            print /flush "";;
            ky = keyw;

            if ky == 13;
                ky = dflt;
            endif;

            if ky == 27;
                goto quit;

            elseif ky == 1116;      /* CTRL_RIGHT */
                dflt = 1116;
                dfltc = "Ctrl-\16";
                cnprt = minc(ncol|cols(mat));
                cstrt = cols(mat)-cnprt+1;

            elseif ky == 1115;      /* CTRL_LEFT */
                dflt = 1115;
                dfltc = "Ctrl-\17";
                cnprt = minc(ncol|cols(mat));
                cstrt = 1;

            elseif ky == 1077;      /* CURSOR_RIGHT */
                dflt = 1077;
                dfltc = "\16";
                cnprt = minc(ncol|cols(mat));
                cstrt = cstrt-cnprt+1;
                if cstrt > cols(mat)-cnprt+1;
                    cstrt = cols(mat)-cnprt+1;
                endif;
            elseif ky == 1075;      /* CURSOR_LEFT */
                dflt = 1075;
                dfltc = "\17";
                cnprt = minc(ncol|cols(mat));
                cstrt = cstrt-cnprt-1;
                if cstrt < 1;
                    cstrt = 1;
                endif;

            elseif ky == 1071;      /* Home */
                cstrt = 1;
                retp(ky,cstrt);

            elseif ky == 1079;      /* End */
                cnprt = minc(ncol|cols(mat));
                cstrt = cols(mat)-cnprt+1;
                retp(ky,cstrt);

            elseif ky == 63;        /* ? */
                print;
                print;
                print "Datalist Commands :";
                print;
                print "PgDn     Page Down";
                print "PgUp     Page Up";
                print "\16        right 1 column";
                print "\17        left  1 column";
                print "\30        up   1 row";
                print "\31        down 1 row";
                print "ctrl-\16   page Right";
                print "ctrl-\17   page Left";
                print "Home     upper left element";
                print "End      lower right element";
                print "Esc      quit";
                print;
                print;
                print "Press Return to continue...";
                ky = keyw;

                ky = dflt;
                goto skipkey;

            elseif not (ky /= klist);
                if cstrt > cols(mat);
                    cstrt = maxc(1|cols(mat) - ncol + 1);
                else;
                    cstrt = cstrt-ncol;
                endif;
                ndpclex;
                cls;