Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

cmpcol

by graff (Chancellor)
on Apr 20, 2002 at 05:30 UTC ( #160735=sourcecode: print w/ replies, xml ) Need Help??

Category: Utilities
Author/Contact Info Dave Graff <graff@ldc.upenn.edu>
Description: Something that makes it easy to find union, intersection, exclusive-or from two lists with a simple command line; very flexible about what you want it to tell you. Also very flexible about what sort of lists you want to feed it. The usage message says it all (I hope). Updated on Aug 17, 2007 with new features. (updated 2012-01-11 to include pod docs and a few new features
#!/usr/bin/env perl

use strict;
use IO::File;
use Getopt::Long;

my $Usage = <<ENDUSE;

Usage: cmpcol {-i|-u|-us|-x|-x1|-x2} [options] file1[:col\#] file2[:co
+l\#]

 Comparison modes:
  -i        : produce intersection of file1[:col\#] and file2[:col\#]
  -u(s)     : produce union (and identify sources)
  -x        : produce exclusive-or, identifying sources
  -x1 (-x2) : produce items unique to file1 (or file2)

 Options:
  -l1 (-l2) : print whole lines from file1 or file2
  -l{a|b} [str] : print whole lines from both files joined by 'str' (d
+ef=:<>:)
  -g(v) ptn : grep (-v) -- only compare lines that (don\'t) contain /p
+tn/
  -c cchar  : ignore material following cchar
  -d delim  : use /delim/ as input column separator (default is white-
+space)

         use "-d tab" for tab-delimited,   "-d vb" for vert.bar-delimi
+ted
             "-d dot" for period-delimited "-d bs" for backslash-delim
+ited

 file1 or file2 may be 'stdin'
 default ':col#' for comparison is first column from each file, which 
+is ':1'
          ':-1' selects last column, ':-2' is next-to-last, etc.
          ':i,j' selects concatenation of columns i and j
ENDUSE

my %opt = ();
my $cmd_okay = GetOptions( \%opt, 'i','u','us','x','x1','x2',
                           'l1','l2','la:s','lb:s','d=s','c=s','g=s','
+gv=s' );
my $arg_okay = ( @ARGV == 2 and $ARGV[0] ne $ARGV[1] and 
                 ( $opt{i} + $opt{u} + $opt{us} + $opt{x} + $opt{x1} +
+ $opt{x2} ) == 1 );

die $Usage unless ( $cmd_okay && $arg_okay );

my ( @clm, @Input );
my $lfn = '';
for ( @ARGV ) {
    my ( $fn, $cl );
    if ( /(.*):(-?[,\d]+)$/ and ( $1 eq 'stdin' or -f $1 )) {
        ( $fn, $cl ) = ( $1, $2 );
    } elsif ( /^stdin$/ or -f ) {
        ( $fn, $cl ) = ( $_, 1 );
    } else {
        die "\n$_ is not a data file.\n$Usage";
    }
    push @Input, new IO::File;
    if ( $fn eq 'stdin' ) {
        $Input[$#Input]->fdopen( fileno(STDIN), 'r' );
    } else {
        $Input[$#Input]->open( "< $fn" ) or die "$fn: $! $Usage";
    }
    push @clm, ( $cl =~ /^-/ or $cl =~ /,/ ) ? $cl : $cl - 1;
}

my $delim = '\s+';
if ( $opt{d} ne '' ) {
    my %ctrl = ( tab => "\t", dot => '\.', vb => '\|', bs => '\\\\' );
    $delim = ( exists( $ctrl{$opt{d}} )) ? $ctrl{$opt{d}} : $opt{d};
}
my $joiner = undef;
my $jointype = ( defined( $opt{la} )) ? 'la' : ( defined( $opt{lb} )) 
+? 'lb' : '';
if ( $jointype ) {
    $joiner = 
        ( $opt{$jointype} eq 'nl' ) ? "\n" :
        ( $opt{$jointype} eq 'tab' ) ? "\t" : ':<>:';
}
my %tknsourc = ();
my %tkndata = ();

sub simple_key
{
    return (split( /$delim/, $_[0] ))[$_[1]];
}
sub multi_key
{
    my @k = map { $_ - 1 } split /,/, $_[1];
    return join( " ", (split( /$delim/, $_[0] ))[@k] );
}

# Read lines from first file

my $getkey = ( $clm[0] =~ /,/ ) ? \&multi_key : \&simple_key;

while ( $_ = $Input[0]->getline ) {
    s/[\r\n]+$//;
    s/$opt{c}.*// if ( $opt{c} ne "" );
    next if ( /^\s*$/ || ( $opt{g} ne "" && ! /$opt{g}/ ) || ( $opt{gv
+} ne "" && /$opt{gv}/ ));
    s/^\s*// if ( $delim eq '\s+' );   # for /\s+/ delimited data, rem
+ove initial whitespace first
    my $k = &$getkey( $_, $clm[0] );
    $tknsourc{$k} .= "1";
    if ( $opt{l1} || defined( $joiner )) {
        $tkndata{$k} .= "$_\n";
    } 
    elsif ( $opt{l2} ) {
        $tkndata{$k} = "($k)\n";
    }
}

# Now do the same for second file

$getkey = ( $clm[1] =~ /,/ ) ? \&multi_key : \&simple_key;

while ( $_ = $Input[1]->getline ) {
    s/[\r\n]+$//;
    s/$opt{c}.*// if ( $opt{c} ne "" );
    next if ( /^\s*$/ || ( $opt{g} ne "" && ! /$opt{g}/ ) || ( $opt{gv
+} ne "" && /$opt{gv}/ ));
    s/^\s*// if ( $delim eq "\\s+" );
    my $k = &$getkey( $_, $clm[1] );
    $tknsourc{$k} .= "2";
    if ( defined( $joiner ) && exists( $tkndata{$k} )) {
        if ( $tkndata{$k} =~ /\n/ ) {
            $tkndata{$k} =~ s/\n/\x08$_\x0b/;
        }
        else {
            my ( $prefix ) = ( $jointype eq 'la' ) ? ( $tkndata{$k} =~
+ /^([^\x08]+)/ ) : '';
            $tkndata{$k} .= "$prefix\x08$_\x0b";
        }
    }
    elsif ( $opt{l2} ) {
        my $newval = (( ! exists( $tkndata{$k} )) || $tkndata{$k} eq "
+($k)\n" ) ?
            "$_\n" : $tkndata{$k} . "$_\n";
        $tkndata{$k} = $newval;
    }
    elsif ( $opt{l1} && ! exists( $tkndata{$k} )) {
        $tkndata{$k} = "($k)\n";
    }
}

# Now print the desired results

if ( $opt{i} ) {  # print the intersection: all records where $tknsour
+c{} contains "12"
    foreach my $k ( sort( keys( %tknsourc ))) {
        &printData( $k ) if ( $tknsourc{$k} =~ /12/ );
    }
}
elsif ( $opt{u} || $opt{us} ) {  # print the union: all records
    foreach my $k ( sort( keys( %tknsourc ))) {
        if ( $opt{us} ) {
            my $src = $tknsourc{$k};
            $src =~ s/11+/+1/;
            $src =~ s/22+/2+/;
            print "$k <$src\n";
        } else {
            &printData( $k );
        }
    }
}
elsif ( $opt{x} ) {  # print exclusive-or: all records where $tknsourc
+{} doesn't show "12"
    foreach my $k ( sort( keys( %tknsourc ))) {
        if ( $tknsourc{$k} !~ /12/ ) {
            my $src = $tknsourc{$k};
            $src =~ s/11+/+1/;
            $src =~ s/22+/2+/;
            print "$k <$src\n";
        }
    }
}
elsif ( $opt{x1} ) {  # print excl-or-1: all records where $tknsourc{}
+ doesn't show "2"
    foreach my $k ( sort( keys( %tknsourc ))) {
        &printData( $k ) if ( $tknsourc{$k} !~ /2/ );
    }
}
elsif ( $opt{x2} ) {  # print excl-or-2: all records where $tknsourc{}
+ doesn't show "1"
    foreach my $k ( sort( keys( %tknsourc ))) {
        &printData( $k ) if ( $tknsourc{$k} !~ /1/ ); 
    }
}

sub printData
{
    my( $k ) = @_;
    $_ = ( $opt{l1} or $opt{l2} or defined( $joiner )) ? $tkndata{$k} 
+: "$k\n";
    if ( $jointype eq 'la' and /([^\x08\x0b]+)\x0b[^\x08\x0b]*\n/ ) {
        my $suffix = $1;
        s/\n/\x08$suffix\x0b/g;
    }
    if ( defined( $joiner )) {
        s/\x08/$joiner/g;
        tr/\x0b/\n/;
    }
    print;
}

=head1 NAME

cmpcol

=head1 SYNOPSIS

 cmpcol {-i|-u|-us|-x|-x1|-x2} [options] file1[:col\#] file2[:col\#]

 Comparison modes:
  -i        : produce intersection of file1[:col\#] and file2[:col\#]
  -u(s)     : produce union (and identify sources)
  -x        : produce exclusive-or, identifying sources
  -x1 (-x2) : produce items unique to file1 (or file2)

 Options:
  -l1 (-l2) : print whole lines from file1 or file2
  -l{a|b} [str] : print both whole lines joined by 'str' (def=:<>:)
  -g(v) ptn : grep (-v), only compare lines that (don't) contain /ptn/
  -c cchar  : ignore material following cchar
  -d delim  : use /delim/ as input column separator (def=whitespace)

         use "-d tab": tab-delimited,   "-d vb": vert.bar-delimited
             "-d dot": period-delimited "-d bs": backslash-delimited

 file1 or file2 may be 'stdin'
 default ':col#' for comparison is first column from each file (':1')
          ':-1' selects last column, ':-2' is next-to-last, etc.
          ':i,j' selects concatenation of columns i and j

=head1 DESCRIPTION

Given two lists as input (either of which could be stdin), cmpcol can
output the union, intersection or differences, and will print these to
stdout.  One or both inputs may be treated as multi-column tables
where one or more specified columns can be used to determine the set
relations.

By default the first space-separated token on each line of both files
is used as the key field, and only the unique set of keys meeting the
chosen condition is printed as output.

When using one of the "-l" options to output full lines from one or
both inputs, multiple occurrences of each key will be listed
exhaustively with the full lines that contain them.

Both "-la [sep]" and "-lb [sep]" will list full lines from both
inputs, joined together one matching pair per line, with the provided
"sep" string as the delimiter between the two source strings.  The
default separator is ":<>:".

The difference between -la and -lb has to do with happens when a given
key occurs more often in one input than the other.  The following
example will demonstrate.  Given these two input files:

 in1:
      x foo
      y bar
      z faz
      z gar
      w boo

 in2:
      a moo
      b mar
      y naz
      y paz
      z noo

The output of "cmpcol -la -i in1 in2" will produce four full lines by
repeating one line from each input:

 y bar:<>:y naz
 y bar:<>:y paz
 z faz:<>:z noo
 z gar:<>:z noo

The output of "cmpcol -lb -i in1 in2" will produce two full lines and
two partial lines -- notice that the "sep" string (the default ":<>:"
in this case) will be line-initial when there's an extra instance of
the key in the second input, and is absent from the line when the
first input has the extra instance of the key:

 y bar:<>:y naz
 :<>:y paz
 z faz:<>:z noo
 z gar

It's often more useful to use "-la tab" or "-lb tab".

=head1 AUTHOR

David Graff <graff (at) ldc (dot) upenn (dot) edu>

=cut

Comment on cmpcol
Download Code
Re: cmpcol
by rinceWind (Monsignor) on Apr 20, 2002 at 10:30 UTC
    graff,

    Have you looked at the module Algorithm::Diff? This might be extremely relevant to your cmpcol script.

      Thanks! I'm sure to find good uses for Algorithm::Diff. While that module covers some similar issues/situations, I'll keep cmpcol as-is: to compare sets of elements from two lists in terms of intersection, union and xor, regardless of the input ordering of elements within each set.

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://160735]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (7)
As of 2014-08-27 10:56 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (237 votes), past polls