Gibt es für Zeile x einer Matrix andere Zeilen die ein Subset dieser Zeile sind? (Allgemeines zu Perl)

[thread]15552[/thread]

Gibt es für Zeile x einer Matrix andere Zeilen die ein Subset dieser Zeile sind?

Leser: 22

Articles: hide open all | hide show old branches

+12 replies

leo11

2010-10-19 15:06

User since
2008-08-14
250 Artikel
BenutzerIn
[default_avatar]

Hi.

Gegeben ist eine Matrix bestehend aus 0,1 und -. Darin möchte ich für jede Zeile prüfen, ob es andere Zeilen gibt, die eine Teilmenge dieser Zeile sind. Mit etwas Hilfe hab ich diese Lösung hinbekommen:

Code (perl): (dl )

#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;

my @all = (<DATA>);
my @all_cp = @all;

foreach my $row (@all) {
    chomp $row;

    my @target_line = split ' ', $row;
    print "\nTarget:\t\t$row\n";

    foreach my $line (@all_cp) {
        chomp $line;
        my @line_to_comp = split ' ', $line;
        next if $line_to_comp[0] eq $target_line[0]; # do not compare the same line with each other
        my ($digits, $dashes) = (0,0);

        for my $index ( 1 .. $#target_line ) { # ignore column 0
            # both are digits and they are equal
            if ( 2 == grep( { /^\d/ } $target_line[$index], $line_to_comp[$index] )
                 and $target_line[$index] == $line_to_comp[$index]
               ) {
                $digits++;

            } elsif ( $line_to_comp[$index] eq "-" ) {
                $dashes++;
            } else {
                last;
            }
        }
        if ( $dashes != (scalar @target_line - 1) and ($digits + $dashes) == (scalar @target_line - 1)) { # -1 because of column 0
            print "Subset:\t\t$line\n";
        } else {
            # print "Not a subset:\t$line\n";
        }
    }
}
__DATA__
row18 - 0 0 1 0 0 - - - 0 0 - - - - - - - - - - - - - - - -
row19 - 0 0 0 - - - - 1 0 0 - - - - - - - - - - - - - - - -
row20 - 0 0 - - - - 1 - 0 0 - - - - - - - - - - - - - - - -
row21 - 0 0 - - - - - - 0 0 - - - - 1 0 0 - - - - - - - - -
row22 - 0 0 - - - - - - 0 0 - - - - 0 - - - 1 - - - - - - -
row23 - 0 0 - - - - - - 0 0 - - - - - - - - - 1 - - - - - -
row24 - 0 0 - - - - - - 0 0 - - - - - - - - - - 1 0 0 - - -
row25 - 0 0 - - - - - - 0 0 - - - - - - - - - - 0 - - - 1 -
row26 - 0 0 - - - - - - 0 0 - - - - - - - - - - - - - - - 1
row27 - 0 0 - - - - - - 1 0 0 - - - - - - - - - - - - - - -
row28 - 0 0 - - - - - - 0 - - - - 1 - - - - - - - - - - - -
row29 - 0 0 - - - - - - - - - 1 - - - - - - - - - - - - - -
row30 1 0 0 - 1 - - - - 0 0 - - - - - - 1 - - - - - - - - -
row31 1 0 0 - 1 - - - - 0 0 - - - - - - - - - - - 1 - - - -
row32 1 0 0 - 1 - - - - 0 0 - - - - - - 1 - - - - 1 - - - -
row33 1 0 0 - - - 1 - - 0 0 - - - - - - - - - - - - - - - -
row34 1 0 0 - - - - - - 0 0 - - - - - - - 1 - - - - - - - -
row35 1 0 0 - - - - - - 0 0 - - - - - - - - - - - - - 1 - -
row36 1 0 0 - - - - - - 0 0 - - - - - - 1 - - - - 1 - - - -
row37 1 0 0 - 1 - - - - - 1 - - - - - - 1 - - - - - - - - -
row38 1 0 0 - 1 - - - - - 1 - - - - - - - - - - - 1 - - - -
row39 1 0 0 - 1 - - - - - 1 - - - - - - 1 - - - - 1 - - - -
row40 1 0 0 - - - 1 - - - 1 - - - - - - - - - - - - - - - -
row41 1 0 0 - - - - - - - 1 - - - - - - - 1 - - - - - - - -
row42 1 0 0 - - - - - - - 1 - - - - - - - - - - - - - 1 - -
row43 1 0 0 - - - - - - - 1 - - - - - - 1 - - - - 1 - - - -
row44 1 0 0 - - - - - - - - 1 - 1 - - - - - - - - - - - - -
row45 - 1 - - - - - - - 1 0 0 - - - - - - - - - - - - - - -
row46 - 1 - - - - - - - 0 - - - - 1 - - - - - - - - - - - -
row47 - 1 - - - - - - - - - - 1 - - - - - - - - - - - - - -
row48 - - 1 - - - - - - 1 0 0 - - - - - - - - - - - - - - -
row49 - - 1 - - - - - - 0 - - - - 1 - - - - - - - - - - - -
row50 - - 1 - - - - - - - - - 1 - - - - - - - - - - - - - -
row51 - 1 0 - - - - - - - - - 0 - - - - - - - - - - - - - -
row52 - 0 1 - - - - - - - - - 0 - - - - - - - - - - - - - -
row53 - 1 0 - - - - - - - - - - - 0 - - - - - - - - - - - -
row54 - 0 1 - - - - - - - - - - - 0 - - - - - - - - - - - -
row55 - 1 0 - - - - - - 0 0 - - - - - - - - - - - - - - - -
row56 - 0 1 - - - - - - 0 0 - - - - - - - - - - - - - - - -

Nur mal aus Interesse: Ist das eine gute Aufgabe für eine rekursive Lösung mit einem 2D Array? Ggf. wie würde die aussehen?

topeg

2010-10-19 15:28

User since
2006-07-10
2611 Artikel
BenutzerIn

user image

Mit einem hash ist es viel schneller und übersichtlicher :-)
z.B so (ungetestet):

Code (perl): (dl )

#!/usr/bin/perl
use strict;
use warnings;

my %index=();

my $pos=0;
while(my $line=<DATA>)
{
  chomp($line);
  (my $compare=$line)=~s/^.+?\s+//;

  # EDIT:
  # zeilen sollen identisch sein...
  #$compare=~s/\d+/1/g;

  $compare=~s/\s+//g;
  push(@{$index{$compare}},[$pos,$line]);
  $pos++;
}

# Ausgabe
for my $lines (values(%index))
{
  print "Subsets:\n";
  for my $line (@$lines)
  {
    print "   Line: $line->[0] => $line->[1]\n";
  }
}

__DATA__
row18 - 0 0 1 0 0 - - - 0 0 - - - - - - - - - - - - - - - -
row19 - 0 0 0 - - - - 1 0 0 - - - - - - - - - - - - - - - -
row20 - 0 0 - - - - 1 - 0 0 - - - - - - - - - - - - - - - -
row21 - 0 0 - - - - - - 0 0 - - - - 1 0 0 - - - - - - - - -
row22 - 0 0 - - - - - - 0 0 - - - - 0 - - - 1 - - - - - - -
row23 - 0 0 - - - - - - 0 0 - - - - - - - - - 1 - - - - - -
row24 - 0 0 - - - - - - 0 0 - - - - - - - - - - 1 0 0 - - -
row25 - 0 0 - - - - - - 0 0 - - - - - - - - - - 0 - - - 1 -
row26 - 0 0 - - - - - - 0 0 - - - - - - - - - - - - - - - 1
row27 - 0 0 - - - - - - 1 0 0 - - - - - - - - - - - - - - -
row28 - 0 0 - - - - - - 0 - - - - 1 - - - - - - - - - - - -
row29 - 0 0 - - - - - - - - - 1 - - - - - - - - - - - - - -
row30 1 0 0 - 1 - - - - 0 0 - - - - - - 1 - - - - - - - - -
row31 1 0 0 - 1 - - - - 0 0 - - - - - - - - - - - 1 - - - -
row32 1 0 0 - 1 - - - - 0 0 - - - - - - 1 - - - - 1 - - - -
row33 1 0 0 - - - 1 - - 0 0 - - - - - - - - - - - - - - - -
row34 1 0 0 - - - - - - 0 0 - - - - - - - 1 - - - - - - - -
row35 1 0 0 - - - - - - 0 0 - - - - - - - - - - - - - 1 - -
row36 1 0 0 - - - - - - 0 0 - - - - - - 1 - - - - 1 - - - -
row37 1 0 0 - 1 - - - - - 1 - - - - - - 1 - - - - - - - - -
row38 1 0 0 - 1 - - - - - 1 - - - - - - - - - - - 1 - - - -
row39 1 0 0 - 1 - - - - - 1 - - - - - - 1 - - - - 1 - - - -
row40 1 0 0 - - - 1 - - - 1 - - - - - - - - - - - - - - - -
row41 1 0 0 - - - - - - - 1 - - - - - - - 1 - - - - - - - -
row42 1 0 0 - - - - - - - 1 - - - - - - - - - - - - - 1 - -
row43 1 0 0 - - - - - - - 1 - - - - - - 1 - - - - 1 - - - -
row44 1 0 0 - - - - - - - - 1 - 1 - - - - - - - - - - - - -
row45 - 1 - - - - - - - 1 0 0 - - - - - - - - - - - - - - -
row46 - 1 - - - - - - - 0 - - - - 1 - - - - - - - - - - - -
row47 - 1 - - - - - - - - - - 1 - - - - - - - - - - - - - -
row48 - - 1 - - - - - - 1 0 0 - - - - - - - - - - - - - - -
row49 - - 1 - - - - - - 0 - - - - 1 - - - - - - - - - - - -
row50 - - 1 - - - - - - - - - 1 - - - - - - - - - - - - - -
row51 - 1 0 - - - - - - - - - 0 - - - - - - - - - - - - - -
row52 - 0 1 - - - - - - - - - 0 - - - - - - - - - - - - - -
row53 - 1 0 - - - - - - - - - - - 0 - - - - - - - - - - - -
row54 - 0 1 - - - - - - - - - - - 0 - - - - - - - - - - - -
row55 - 1 0 - - - - - - 0 0 - - - - - - - - - - - - - - - -
row56 - 0 1 - - - - - - 0 0 - - - - - - - - - - - - - - - -

EDIT: Entschuldige war zu schnell, habe nicht beachtet was du unter einem Subset verstehst.
Last edited: 2010-10-19 15:35:13 +0200 (CEST)

topeg

2010-10-19 18:26

User since
2006-07-10
2611 Artikel
BenutzerIn

user image

So nun habe ich verstanden was du machen willst, das geht durchaus kürzer:

Code (perl): (dl )

#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;

my @index=();

my $pos=0;
while(my $line=<DATA>)
{
  chomp($line);
  next unless($line);
  (my $compare=$line)=~s/^.+?\s+//;
  $compare=~s/\s+$//;

  push(@index,[$pos,$line,[split(/\s+/,$compare)]]);
  $pos++;
}

for my $test (@index)
{
  print "TEST:     $test->[1]\n";
  for my $comp (@index)
  {
    # mindestens ein Zahl
    next unless( grep{$_ ne '-'}@{$comp->[2]} );

    # nicht die selbe Zeile
    next if($test->[0] == $comp->[0]);

    my $cnt=0;
    for my $p (0..$#{$test->[2]})
    {
      my $sval=$test->[2]->[$p];
      my $dval=$comp->[2]->[$p];
      # verkürzte Bedingung :-)
      $cnt++ if($dval eq $sval || $dval eq '-');
    }

    print "  SUBSET: $comp->[1]\n" if($cnt==@{$test->[2]})
  }
}

__DATA__
row18 - 0 0 1 0 0 - - - 0 0 - - - - - - - - - - - - - - - -
row19 - 0 0 0 - - - - 1 0 0 - - - - - - - - - - - - - - - -
row20 - 0 0 - - - - 1 - 0 0 - - - - - - - - - - - - - - - -
row21 - 0 0 - - - - - - 0 0 - - - - 1 0 0 - - - - - - - - -
row22 - 0 0 - - - - - - 0 0 - - - - 0 - - - 1 - - - - - - -
row23 - 0 0 - - - - - - 0 0 - - - - - - - - - 1 - - - - - -
row24 - 0 0 - - - - - - 0 0 - - - - - - - - - - 1 0 0 - - -
row25 - 0 0 - - - - - - 0 0 - - - - - - - - - - 0 - - - 1 -
row26 - 0 0 - - - - - - 0 0 - - - - - - - - - - - - - - - 1
row27 - 0 0 - - - - - - 1 0 0 - - - - - - - - - - - - - - -
row28 - 0 0 - - - - - - 0 - - - - 1 - - - - - - - - - - - -
row29 - 0 0 - - - - - - - - - 1 - - - - - - - - - - - - - -
row30 1 0 0 - 1 - - - - 0 0 - - - - - - 1 - - - - - - - - -
row31 1 0 0 - 1 - - - - 0 0 - - - - - - - - - - - 1 - - - -
row32 1 0 0 - 1 - - - - 0 0 - - - - - - 1 - - - - 1 - - - -
row33 1 0 0 - - - 1 - - 0 0 - - - - - - - - - - - - - - - -
row34 1 0 0 - - - - - - 0 0 - - - - - - - 1 - - - - - - - -
row35 1 0 0 - - - - - - 0 0 - - - - - - - - - - - - - 1 - -
row36 1 0 0 - - - - - - 0 0 - - - - - - 1 - - - - 1 - - - -
row37 1 0 0 - 1 - - - - - 1 - - - - - - 1 - - - - - - - - -
row38 1 0 0 - 1 - - - - - 1 - - - - - - - - - - - 1 - - - -
row39 1 0 0 - 1 - - - - - 1 - - - - - - 1 - - - - 1 - - - -
row40 1 0 0 - - - 1 - - - 1 - - - - - - - - - - - - - - - -
row41 1 0 0 - - - - - - - 1 - - - - - - - 1 - - - - - - - -
row42 1 0 0 - - - - - - - 1 - - - - - - - - - - - - - 1 - -
row43 1 0 0 - - - - - - - 1 - - - - - - 1 - - - - 1 - - - -
row44 1 0 0 - - - - - - - - 1 - 1 - - - - - - - - - - - - -
row45 - 1 - - - - - - - 1 0 0 - - - - - - - - - - - - - - -
row46 - 1 - - - - - - - 0 - - - - 1 - - - - - - - - - - - -
row47 - 1 - - - - - - - - - - 1 - - - - - - - - - - - - - -
row48 - - 1 - - - - - - 1 0 0 - - - - - - - - - - - - - - -
row49 - - 1 - - - - - - 0 - - - - 1 - - - - - - - - - - - -
row50 - - 1 - - - - - - - - - 1 - - - - - - - - - - - - - -
row51 - 1 0 - - - - - - - - - 0 - - - - - - - - - - - - - -
row52 - 0 1 - - - - - - - - - 0 - - - - - - - - - - - - - -
row53 - 1 0 - - - - - - - - - - - 0 - - - - - - - - - - - -
row54 - 0 1 - - - - - - - - - - - 0 - - - - - - - - - - - -
row55 - 1 0 - - - - - - 0 0 - - - - - - - - - - - - - - - -
row56 - 0 1 - - - - - - 0 0 - - - - - - - - - - - - - - - -

+9 replies
clms

2010-10-19 19:55
User since
2010-08-29
373 Artikel
BenutzerIn
Hier mein Ansatz:
a) möglichst viel aus der inneren Schleife rausziehen
b) die Pattern in Bitvektoren verwandeln und numerisch vergleichen

Für bin2num() gibt es sicher schon eine fertige Funktion,
ich weiss nur nicht wo.
So ist der Code ist nicht unbedingt kürzer, sollte aber schneller sein. Wenn die Zeilen länger werden muss man use bigint setzen.
Code (perl): (dl )

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47

use strict; use warnings; use Data::Dumper; sub bin2num($) { my $v = 0; foreach my $b (split(//,shift)) { $v <<= 1; $v += $b; } $v; } sub prepare_line($) { my $line = shift; chomp $line; my $l = $line; $l =~ s/^row(\d+)\s+//; $l =~ s/\s+//g; # Leerzeichen entfernen; my $mask = $l; $mask =~ tr/-01/011/; $mask = bin2num($mask); # Ziffer => bit gesetzt my $pattern = $l; $pattern =~ tr/-01/001/; $pattern = bin2num($pattern); # '1' => bit gesetzt return { line => $line, mask => $mask,pattern => $pattern}; } my @all = map {prepare_line($_)} (<DATA>); foreach my $target (@all) { print "\nTarget:\t\t",$target->{line},"\n"; foreach my $comp (@all) { next if $target->{line} eq $comp->{line}; # gleiche Zeile # numerischer Vergleich der in $comp gesetzten Ziffern, erst '0' dann '1' if (($comp->{mask} & $target->{mask} & ~$target->{pattern}) == ($comp->{mask} & ~$comp->{pattern}) and ($comp->{mask} & $target->{pattern}) == ($comp->{mask} & $comp->{pattern})) { print "Subset:\t\t",$comp->{line},"\n"; } } }
- +8 replies
- topeg
  
  2010-10-19 21:06
  
  User since
  2006-07-10
  2611 Artikel
  BenutzerIn
  
  Irgendwo komm eich mit den Vergleichsbedingungen in deinem Code nicht klar. Sehe ich es richtig, dass für dich "1" => "-" OK ist aber "0" => "-" nicht? Das würde sich nicht mit der Logik aus dem Originalcode decken. Soweit ich das sehe gilt:
  Gleichheit ist OK, Zahl => '-' ist OK, nur "-" => Zahl ist es nicht.
  - +7 replies
  - clms
    
    2010-10-19 22:13
    User since
    2010-08-29
    373 Artikel
    BenutzerIn
    
    2010-10-19T19:06:34 topeg
    Irgendwo komm eich mit den Vergleichsbedingungen in deinem Code nicht klar.
    
    Wenn im Subset eine Ziffer steht, muss im Target an der Stelle die gleiche Ziffer stehen, wenn im Subset ein '-' steht, ist es egal, was im Target steht.
    
    Meinen Vergleich in Zeile 42-44 kann man auch noch vereinfachen:
    
    Code (perl): (dl )
    
    1 2 3
    
    print "Subset:\t\t",$comp->{line},"\n" unless ($comp->{mask} & ($target->{pattern} ^ $comp->{pattern})) || ($comp->{mask} & ~$target->{mask});
    
    In der ersten Zeile wird geschaut, dass jede Ziffer in $comp mit mit dem Pattern von $target übereinstimmt. In der zweiten Zeile wird dann noch sichergestellt, dass überall wo in $comp eine Ziffer ist, auch in $target eine steht, weil ja auch '-' im Patten zu '0' werden.
    - +6 replies
    - topeg
      
      2010-10-19 23:47
      
      User since
      2006-07-10
      2611 Artikel
      BenutzerIn
      
      Ach diese Binäroperatoren. Jetzt verstehe ich es.
      
      Übrigens das Binärkodieren geht einfacher:
      
      Code (perl): (dl )
      
      bin2num($) { return pack("B*",shift) }
      
      EDIT: Korrektur. Ich denke das ist das richtige:
      
      Code (perl): (dl )
      
      1 2 3 4 5 6 7
      
      bin2num($) { my $bin=shift; # gültige 32 Bit Zahl daraus machen. $bin=( '0'x( 32-length $bin ) ).$bin; return unpack("L", pack("B*",$bin)); }
      
      Last edited: 2010-10-19 23:57:50 +0200 (CEST)
      - +5 replies
      - clms
        
        2010-10-20 10:30
        
        User since
        2010-08-29
        373 Artikel
        BenutzerIn
        
        2010-10-19T21:47:52 topeg
        Übrigens das Binärkodieren geht einfacher:
        
        So einfach scheint es doch nicht zu sein :-(
        
        Deine zweite Variante liefert mir für die Eingabe "10110" den Wert 369098752 statt 22.
        
        Nachdem ich kein fertiges bin()-Pedant zu hex() gefunden habe,
        hab' ich es zunächst auch kurz mit pack() versucht, aber - als die
        ersten Versuche nicht fruchteten - schnell aufgegeben, da ich mit pack()
        keine Erfahrungen habe und bei foreach auf sicherem Terrain bin.
        
        Die Schleife kann man auch noch ein bischen kompakter schreiben:
        
        Code (perl): (dl )
        
        1 2 3 4 5
        
        sub bin2num($) { my $n = 0; ($n <<= 1) += $_ foreach split(//,shift); $n; }
        
        +3 replies
        
        pq
        
        2010-10-20 10:55
        
        User since
        2003-08-04
        12208 Artikel
        Admin1
        
        frag doch einfach =)
        
        Code (perl): (dl )
        
        1 2
        
        my $bin = "10110"; my $dec = oct "0b$bin";
        
        perldoc -f oct (macht eben nicht nur oktalzahlen, sondern mit dem präfix "0b" auch binärzahlen.)
        Always code as if the guy who ends up maintaining your code will be a violent psychopath who knows where you live. -- Damian Conway in "Perl Best Practices"
        lesen: Wie frage ich & perlintro brian's Leitfaden für jedes Perl-Problem
        
        topeg
        
        2010-10-20 11:03
        
        User since
        2006-07-10
        2611 Artikel
        BenutzerIn
        
        Das ist mir auch neu, danke für die Info.
        
        clms
        
        2010-10-20 12:22
        
        User since
        2010-08-29
        373 Artikel
        BenutzerIn
        
        2010-10-20T08:55:40 pq
        frag doch einfach =)
        
        Hab ich indirekt ja auch gemacht. Danke für die Info.
        
        Ich hatte extra in perlfunc oben in den Listen nachgeschaut, ob es da
        passende Funktionen gibt (ich konnte mir nicht vorstellen, das es die nicht gibt)
        und hab' dann u.a. pack ausprobiert. Aber auf oct() wäre
        ich ohne Deine Hilfe nicht gekommen.
        
        Aber jetzt habe ich im Abschnitt zu den bitwise operators in perlop gelesen, dass die
        auch bei strings funktionieren. Man muss die Muster garnicht in eine Zahl verwandeln.
        Folgendes funktioniert auch:
        
        Code (perl): (dl )
        
        1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27
        
        sub prepare_line($) { my $line = shift; chomp $line; my $l = $line; $l =~ s/^row\d+\s+//; $l =~ s/\s+//g; # Leerzeichen entfernen; $l =~ tr/-/ /; # '-' durch ' ' ersetzen, wg. Bitfilter my $mask = $l; $mask =~ tr/0/1/; # alle Ziffern => '1' return { line => $line, mask => $mask,pattern => $l}; } my @all = map {prepare_line($_)} (<DATA>); foreach my $target (@all) { print "\nTarget:\t\t",$target->{line},"\n"; foreach my $comp (@all) { next if $target->{line} eq $comp->{line}; # gleiche Zeile print "Subset:\t\t",$comp->{line},"\n" if ($target->{pattern} & $comp->{mask}) eq $comp->{pattern}, } }
        
        topeg
        
        2010-10-20 11:00
        
        User since
        2006-07-10
        2611 Artikel
        BenutzerIn
        
        War gestern doch schon etwas spät. Ich habe nicht mehr daran gedacht, dass Es mit "L" ins Intel Format mit den vertauschen Low-/Hight-Bytes konvertiert wird. Es wird das Format gebraucht bei dem die Byteorder nicht vertauscht ist.
        
        also das funktioniert wie erwartet:
        
        Code (perl): (dl )
        
        1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
        
        #!/usr/bin/perl use strict; use warnings; sub bin2num($) { my $bin=shift; # gültige 32 Bit Zahl daraus machen. $bin=( '0'x( 32-length $bin ) ).$bin; return unpack("N", pack("B*",$bin)); } sub num2bin($) { unpack("B*",pack("N",shift)); } my $bin=num2bin(22); print $bin."->".bin2num($bin)."\n";

View all threads created 2010-10-19 15:06.