intrsect.src

来自「没有说明」· SRC 代码 · 共 126 行

/*
** intrsect.src
** (C) Copyright 1988-1998 by Aptech Systems, Inc.
** All Rights Reserved.
**
** 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.
**
**> intrsect
**
**  Purpose:    Returns the intersection of two vectors, with
**              duplicates removed.
**
**  Format:     y = intrsect(v1,v2,flag);
**
**  Input:      v1      Nx1 vector.
**
**              v2      Mx1 vector.
**
**              flag    scalar, if 1, v1 and v2 are numeric
**                              if 0, character.
**
**  Output:     y       Lx1 vector containing all unique values in that
**                      are in both v1 and v2, sorted in ascending order.
**
**  Remarks:    Place smaller vector first for fastest operation.
**
**              If there are a lot of duplicates it is faster to
**              remove them with unique before calling intrsect.
**
**  Globals:    None
**
**  Example:    let v1 = mary jane linda dawn;
**              let v2 = mary sally jane lisa ruth;
**              y = intrsect(v1,v2,0);
*/

proc intrsect(v1,v2,flag);
    local v,n1,v1i,i,n,mask1,ms,e,idx;

    v = miss(0,0);          /* will hold result; initialize to missing  */
    n1 = rows(v1);

    /* check for complex input */
    if iscplx(v1);
        if hasimag(v1);
            errorlog "ERROR: Not implemented for complex matrices.";
            end;
        else;
            v1 = real(v1);
        endif;
    endif;

    if iscplx(v2);
        if hasimag(v2);
            errorlog "ERROR: Not implemented for complex matrices.";
            end;
        else;
            v2 = real(v2);
        endif;
    endif;

    i = 1;
    do until i > n1;
        v1i = v1[i];
        if not (v1i $/= v2);        /* will work for either numeric or
                                    :: character
                                    */
            v = v|v1i;      /* if any match, add to intersection set  */
        endif;
        i = i + 1;
    endo;

    ndpclex;        /* clear exceptions */

    n = rows(v);    /* number of elements in v, including M in first element */

    if n == 1;      /* no intersection */
        retp( v );          /* done -- if no intersection then M is returned */
    elseif n == 2;          /* 1 element in itersection -- no dups possible */
        retp( v[2] );       /* return second element */
    else;           /* check for duplicates */

        v = trimr(v,1,0);           /* trim the M from 1st element  */

    /* =============== remove duplicates =================== */
        /* sort the result */
        if flag == 1;       /* numeric */
            v = sortc(v,1);
        else;       /* character */
            v = sortcc(v,1);
        endif;

        mask1 = trimr(v,0,1).$==trimr(v,1,0);       /* find successive
                                                    :: matches
                                                    */

        if mask1 == 0;      /* all 0's -- no duplicates */
            retp( v );      /* done */
        elseif mask1 == 1;          /* all 1's -- all duplicates */
            retp( v[1] );           /* return first element only */
        else;

        /* compute indices of all except "runs" of equal elements */

            ms = (mask1|0) - (0|mask1);     /* 1's denote begin, -1's end,
                                            :: 0's otherwise
                                            */

            e = (ms .== 1) .or (ms .== 0 .and (mask1|0) .== 0);
                /* indices */
            idx = packr( seqa(1,1,n-1) + (miss(.not e,1) ) );

            retp( submat(v,idx,0) );
        endif;
    endif;
endp;