dataxchn.src

来自「没有说明」· SRC 代码 · 共 1,159 行 · 第 1/3 页

    { ret,errstr } = retchk;
    dllcall dx_openfile_for_import(ret,errstr,filename,info,names,srange);
    if (ret < 0);
        errorlog errstr;
        retp(0);
    endif;
    nobs = info[1];
    nvars = info[2];
    ntot = nobs;
    if nobs == 0;
        actnobs = 0;
        nobs = floor(bufsz/nvars);
    else;
        nobs = nobs + 1;
        actnobs = 1;
    endif;
    if (nobs*nvars > bufsz);
        errorlog "Data size exceeds buffer size: data will be truncated";
        nobs = floor(bufsz/nvars);
    endif;
    ncases = nobs;
    info[1] = ncases;
    x = zeros(ncases,nvars);        /* set up x large enough */
    { ret,errstr } = retchk;
    dllcall dx_import_read(ret, errstr, x, info);
    if (ret < 0);
        errorlog errstr;
        retp(0);
    endif;
    if not dx_cmnd("close_r",x,info,fmt,filename,names);
        retp(0);
    endif;
    call dx_print("Import completed ");
    if ftype == 19;
        call dx_parse(filename,0);
    endif;          /* clear schema */

    ncases = info[1];       /* actual values read */
    nvars = info[2];        /* actual values read */
    eofflag = info[8];

    if (not eofflag) and (not actnobs);
        errorlog "Warning, data loss: data matrix truncated.\r\l           "\
            "   Increase _dxbuffer";
    endif;
    x = reshape(vecr(x),ncases,nvars);
    x = miss(x,_dxmiss);
    if ftype == 19;
        x = x./(10^_dxprcn)';
    endif;          /* take care of prcn */
    nmiss = nmiss + sumc(vec(x) .== miss(0,0));
    names = names[1:nvars];
    if (nmiss);
        call dx_print("Missing values encountered ");
    endif;

    retp(x,names);

endp;

/**********************************************************************
**                   GAUSS data set import
***********************************************************************/

proc importf(filename,dataset,range,sheet);
    local info, ftype, fmt, ncases, nvars, names, x, ret, errstr, srange,
        rngtype, bufsz, eofflag, actnobs, nobs, retcode, _dxcolhdr,
        _dxascdlim, f1, ncount, ntot, nmaxread, nmiss;

    { ftype,srange,info,retcode } = dx_setimport(filename,sheet,range);
    if (retcode == 0);
        retp(0);
    endif;

    bufsz = _dxbuffer*131072;
    names = zeros(255,1);
    nmiss = 0;
    fmt = srange;
    { ret,errstr } = retchk;
    dllcall dx_openfile_for_import(ret,errstr,filename,info,names,srange);
    if (ret < 0);
        errorlog errstr;
        retp(0);
    endif;

    ntot = info[1];
    nvars = info[2];
    nmaxread = floor(bufsz/nvars);
    ncount = 0;
    if (ntot == 0);
        actnobs = 0;
    else;
        actnobs = 1;
        nmaxread = minc(ntot+1|nmaxread);
    endif;
    x = zeros(nmaxread,nvars);      /* set up x large enough */
    names = names[1:nvars];

    create f1 = ^dataset with ^names,0,8;
    if f1 == -1;
        errorlog "GAUSS data set: " $+ dataset $+ "  could not be created";
        retp(0);
    endif;

    do while 1;
        info[1] = nmaxread;
        { ret,errstr } = retchk;
        dllcall dx_import_read(ret, errstr, x, info);
        if (ret < 0);
            errorlog errstr;
            retp(0);
        endif;
        ncases = info[1];           /* actual values read */
        eofflag = info[8];
        if (ncases > 0);
            x = reshape(vecr(x),ncases,nvars);
            x = miss(x,_dxmiss);
            if ftype == 19;
                x = x./(10^_dxprcn)';
            endif;          /* take care of prcn */
            ncount = ncount + ncases;
            nmiss = nmiss + sumc(vec(x) .== miss(0,0));
            call writer(f1,x);
        endif;
        if (eofflag == 1);
            f1 = close(f1);
            break;
        endif;
    endo;
    eofflag = info[8];

    if not dx_cmnd("close_r",x,info,fmt,filename,names);
        retp(0);
    endif;

    if ftype == 19;
        call dx_parse(filename,0);
    endif;          /* clear schema */

    call dx_print("Import completed ");
    if _dxprint;
        if (actnobs == 1) and (range $== 0);
            print "Number of rows in input file:                 " ntot;
        endif;
        print "Number of cases written to GAUSS data set:     " ncount;
        if nmiss > 0;
            print "Number of missing elements:                   " nmiss;
        endif;
        print "Number of variables written to GAUSS data set: " nvars;
    endif;
    retp(1);

endp;

/**********************************************************************
**                   Import processing
***********************************************************************/
proc 4 = dx_setimport(filename,sheet,range);
    local info, ftype, srange, rngtype, eofflag, nobs, nmiss, x,
        _dxascdlim, _dxcolhdr, ncases, nvars, retcode;

    call dx_header("GAUSS Data Import Facility");
    if not dx_fileexist(filename);
        goto errprcs;
    endif;
    { ftype, _dxcolhdr } = dx_filetype(filename,0);
    if ismiss(ftype);
        goto errprcs;
    elseif (ftype == 91);           /* formatted input */
        ftype = 18;
    endif;
    sheet = sheet - 1;      /* zero based */
    if sheet < 0;
        sheet = 0;
    endif;
    _dxascdlim = _dxtxdlim;
    if (ftype == 18);       /* ASCII file */
        srange = 0;
        rngtype = 0;
        sheet = 0;
        ftype = dx_parse(filename,range);
        if ismiss(ftype);
            goto errprcs;
        endif;
    else;
        { srange,rngtype } = dx_range(range);
        if (rngtype $== -1);
            goto errprcs;
        endif;
    endif;

    ncases = 0;
    nvars = 0;
    x = 0;
    eofflag = 0;
    info = ncases | nvars | ftype | sheet| rngtype | _dxascdlim| _dxcolhdr
        | eofflag ;

    call dx_print("Begin import... " );
    retcode = 1;
    retp(ftype,srange,info,retcode);

errprcs:

    retcode = 0;
    retp(0,0,0,retcode);
endp;

/**********************************************************************
**                   Determing file type
***********************************************************************/
proc 2 = dx_filetype(fname,exflg);
    external string _dxftype;

    local exlst, imlst, fmtlist, begindex, exstem,msg, extindx, fmttype,
        _dxcolhdr, root;

    let imlst =
        "WKS" "WK1" "WK2"                         @ Lotus v1-v2       @
        "WK3" "WK4" "WK5"                         @ Lotus v3-v5       @
        "XLS"                                     @ Excel v2.1-v7.0   @
        "WQ1" "WQ2" "WB1"                         @ Quattro v1-v6     @
        "WRK"                                     @ Symphony v1.0-1.1 @
        "DB2"                                     @ dBase II          @
        "DBF"                                     @ dBase III/IV      @
        "DBF"                                     @ FoxPro, Clipper   @
        "DB"                                      @ Paradox  v3-v5    @
        "CSV" "TXT" "ASC"                         @ ASCII delimited   @
        "PRN"                                     @ ASCII formatted   @
        "DAT" "DHT";                              @ GAUSS data set    @

    let exlst =
        "WKS" "^^^" "^^^"                         @ Lotus v1          @
        "^^^" "^^^" "^^^"                         @                   @
        "XLS"                                     @ Excel v2.1        @
        "WQ1" "^^^" "^^^"                         @ Quattro v1        @
        "WRK"                                     @ Symphony v1.0     @
        "DB2"                                     @ dBase II          @
        "DBF"                                     @ dBase III         @
        "^^^"                                     @                   @
        "DB"                                      @ Paradox v3.0      @
        "CSV" "TXT" "ASC"                         @ ASCII delimited   @
        "PRN"                                     @ ASCII formatted   @
        "DAT" "^^^";                              @ GAUSS data set    @

    let fmtlist = 0 0 0 1 1 1 7 11 11 11
        15 5 6 6 10 18 18 18 91 99 99 ;

    /* Get extension */
    if _dxftype $/= "";     /* file type predetermined */
        exstem = _dxftype;
    else;
        begindex = strrindx(fname,".",strlen(fname));
        if begindex;
            exstem = strsect(fname,begindex+1,3);
            root = strsect(fname,1,begindex);
        else;
            fmttype = miss(0,0);
            msg = " No extension was found in filename: " $+ fname ;
            errorlog msg;
            retp(miss(0,0));
        endif;
    endif;

/* match extension to file types */
    if exflg;       /* export flag */
        extindx = indcv(exstem,exlst);
    else;
        extindx = indcv(exstem,imlst);
    endif;
    if not ismiss(extindx);
        fmttype = fmtlist[extindx];
        _dxcolhdr = _dxwkshdr*(fmttype < 18) + _dxaschdr*(fmttype >= 18);
    else;
        fmttype = miss(0,0);
        msg = " The extension '" $+ exstem $+ "' is not supported ";
        errorlog msg;
        _dxcolhdr = 0;
    endif;

/* *** Temp code for schema*** */

    /* if (fmttype == 18) and (not filesa(root$+"sch") $== ""); fmttype =
    :: 19; endif;
    */

    retp(fmttype, _dxcolhdr);
endp;

/**********************************************************************
**                   Execute a dataexchange (dx) command
***********************************************************************/

proc dx_cmnd(cmnd, x, info, fmt, filename, names);
    /* returns 1 on success, 0 on failure */
    local ret, errstr, ftype, outfile;

    { ret,errstr } = retchk;
    ftype = info[3];
    if (cmnd $== "open_w");
        if ftype == 91;
            outfile = filename;
            output file = ^outfile reset;
            outwidth 256;
            screen off;
            output on;
            if info[5];
                call formatcv("-*.*s" ~_dxwidth ~ 8);
                call printfmt(fmt[.,1]',0);
                print "";
            endif;
            call formatnv("*.*lf" ~_dxwidth ~ _dxprcn);
        else;
            dllcall dx_openfile_for_export(ret,errstr,info,fmt,filename);
        endif;

    elseif (cmnd $== "open_r");
        dllcall dx_openfile_for_import(ret,errstr,filename,info,names,fmt);

    elseif (cmnd $== "write");
        if ftype == 91;
            errstr = "printfmt failed";
            ret = printfmt(x,1) - 1 ;
        else;
            fmt = fmt[.,2];     /* only need type column for this call */
            dllcall dx_export_write(ret, errstr, x, info, fmt);
        endif;

    elseif (cmnd $== "read");
        dllcall dx_import_read(ret, errstr, x, info);

    elseif (cmnd $== "close_w");
        if ftype == 91;
            output off;
            screen on;
            output file = output.out;
        endif;
        dllcall dx_closefile(ret, errstr);

    elseif (cmnd $== "close_r");
        dllcall dx_closefile(ret, errstr);

    else;
        ret = -1;
        errstr = "Program error - dx_command not found";
    endif;

    if (ret < 0);
        errorlog errstr;
        retp(0);
    else;
        retp(1);
    endif;

endp;

/**********************************************************************
**                   Set up error returns
***********************************************************************/
proc 2 = retchk;
    local ret, errstr;
    ret = 0;
    errstr = "                                                    ";
    retp(ret,errstr);
endp;

/**********************************************************************
**                   Check that file exists
***********************************************************************/
proc dx_fileexist(filename);
    local msg;
    if (not filesa(filename) $== "");
        retp(1);
    else;
        msg = " The file " $+ filename $+ " could not be located ";
        errorlog msg;
        retp(0);
    endif;
endp;

/**********************************************************************
**                   Set up spreadsheet format
***********************************************************************/
proc dx_makefmt(nvars,namelist);
    local fmt, dxname;
    fmt = zeros(nvars,4);
    let dxname = "Var:";