I am having the below hash of hash,
my $hash = {1 => {'a'=>'a1','b'=>'b1', 'c'=>'c1', 'd'=>'d1'},
2 => {'a'=>'e1','b'=>'f1', 'c'=>'g1', 'd'=>'h1'},
3 => {'a'=>'i1','b'=>'j1','c'=>'k1', 'd'=>'l1'},
4 => {'a'=>'m1','b'=>'n1','c'=>'o1','d'=>'p1'}};
I want to display the above hash of hash in perl formatted manner. The hash of hash is dynamic in nature so we can have additional keys later on as well.
I am using the below code to generate the hash of hash into a proper format.
use strict;
my $hash = {1 => {'a'=>'a1','b'=>'b1', 'c'=>'c1', 'd'=>'d1'},
2 => {'a'=>'e1','b'=>'f1', 'c'=>'g1', 'd'=>'h1'},
3 => {'a'=>'i1','b'=>'j1','c'=>'k1', 'd'=>'l1'},
4 => {'a'=>'m1','b'=>'n1','c'=>'o1','d'=>'p1'}};
my #a = qw(1 2);
my #b = qw(3 4);
&displayreport($hash, \#a);
print "new display\n\n";
&displayreport($hash, \#b);
my($i,$j,$k,$l);
format STDOUT_TOP =
A B C D
-- -- -- --
.
format OUTPUT=
#<< #<< #<< #<<
$i,$j,$k,$l
.
sub displayreport{
my ($x, $y) = #_;
$~ = "STDOUT_TOP";
write;
foreach(#$y) {
$i = $hash->{$_}->{a};
$j = $hash->{$_}->{b};
$k = $hash->{$_}->{c};
$l = $hash->{$_}->{d};
$~ = "OUTPUT";
write();
}
}
The Output I got is,
A B C D
-- -- -- --
A B C D
-- -- -- --
a1 b1 c1 d1
e1 f1 g1 h1
new display
A B C D
-- -- -- --
i1 j1 k1 l1
m1 n1 o1 p1
where the header in the first case is repeated.
I need the output as,
A B C D
-- -- -- --
a1 b1 c1 d1
e1 f1 g1 h1
new display
A B C D
-- -- -- --
i1 j1 k1 l1
m1 n1 o1 p1
Where I am doing wrong. Kindly assist.
Rename STDOUT_TOP to STDOUT_TOPX and it works. But I have no idea why.
format's suffixed with _TOP have special meaning as Top of Form Processing
You can take advantage of this more explicitly by opening an output to a new filehandle, and using the $^ variable for setting a $FORMAT_TOP_NAME.
This is demonstrated by the following:
use strict;
use warnings;
my $hash = {
1 => { 'a' => 'a1', 'b' => 'b1', 'c' => 'c1', 'd' => 'd1' },
2 => { 'a' => 'e1', 'b' => 'f1', 'c' => 'g1', 'd' => 'h1' },
3 => { 'a' => 'i1', 'b' => 'j1', 'c' => 'k1', 'd' => 'l1' },
4 => { 'a' => 'm1', 'b' => 'n1', 'c' => 'o1', 'd' => 'p1' },
};
displayreport( $hash, [1,2] );
print "\nnew display\n";
displayreport( $hash, [3,4] );
format OUTPUT_TOP =
A B C D
-- -- -- --
.
my ( $i, $j, $k, $l );
format OUTPUT=
#<< #<< #<< #<<
$i,$j,$k,$l
.
sub displayreport {
my ( $hash, $keys ) = #_;
open my $fh, '>', \my $output or die "Can't open: $!";
my $ofh = select($fh);
$^ = "OUTPUT_TOP";
$~ = "OUTPUT";
foreach (#$keys) {
($i, $j, $k, $l) = #{$hash->{$_}}{qw(a b c d)};
write();
}
select($ofh);
close $fh;
print $output;
}
Outputs:
A B C D
-- -- -- --
a1 b1 c1 d1
e1 f1 g1 h1
new display
A B C D
-- -- -- --
i1 j1 k1 l1
m1 n1 o1 p1
Two Alternatives
First, if you really want to use formats, I suggest you use the more modern Perl6::Form.
Second, I would strongly recommend using the much simpler printf and sprintf for this type of basic formatting and skip formats all together:
displayreport( $hash, [1,2] );
print "\nnew display\n";
displayreport( $hash, [3,4] );
sub displayreport {
my ( $hash, $keys ) = #_;
my $fmt = " %3s %3s %3s %3s\n";
printf $fmt, qw(A B C D);
printf $fmt, qw(-- -- -- --);
foreach (#$keys) {
printf $fmt, #{$hash->{$_}}{qw(a b c d)};
}
}
Output is identical to the previous script.
Related
How can I print a hash in Perl, such that 3 key value pairs are printed on each line?
print %hash;
This will print key value pairs each in a line.
To display the hash, so "that 3[n] key value pairs are printed on each line", you can use a counter ($n) and % (modulo op) to determine when to print a "\n". Demo:
use Modern::Perl;
my %h = ();
for (0..7) {
$h{$_} = chr(65 + $_);
}
print %h, "\n";
my $cols = +$ARGV[0] || 5;
my $n = -$cols;
for my $key (keys %h) {
print $key, ' => ', $h{$key}, 0 == ++$n % $cols ? "\n" : "\t\t";
}
print $n % $cols ? "\n------" : "------";
output:
perl -w 31444449.pl 1
6G4E1B3D0A7H2C5F
6 => G
4 => E
1 => B
3 => D
0 => A
7 => H
2 => C
5 => F
------
perl -w 31444449.pl
6G4E1B3D0A7H2C5F
6 => G 4 => E 1 => B 3 => D 0 => A
7 => H 2 => C 5 => F
------
perl -w 31444449.pl 3
6G4E1B3D0A7H2C5F
6 => G 4 => E 1 => B
3 => D 0 => A 7 => H
2 => C 5 => F
------
Borodin's solutions, however, is simpler.
See mpapec answer for a much improved version.
A very simple way to do this is to copy all the keys and values to an array, and then print six (three pairs) of those at a time
use strict;
use warnings;
my %h = map { $_ => 1 } 'A' .. 'H';
my #kv = %h;
while ( my #row = splice #kv, 0, 6 ) {
print "#row\n";
}
output
B 1 C 1 A 1
D 1 E 1 G 1
F 1 H 1
You can use natatime from List::MoreUtils:
use List::MoreUtils qw/natatime/;
my $it = natatime 6, %ENV;
while (my #vals = $it->()) {
print "#vals\n";
}
List::MoreUtils isn't in core modules, you need to install it.
Thanks All. I tried this and it worked.
my #keylist=sort keys %hash;
my $counter=0;
foreach(#keylist){
#printing the key value pairs
printf "%-15s :%3d ",$_,$hash{$_};
$counter++;
if($counter==3){
$counter=0;
print "\n";
}
}
print "\n";
If you really just want to print hash and check the values for debugging or for analysing then use
use Data::Dumper;
print Dumper(\%hash);
This print hash keys and values at any n number of levels
This question already has answers here:
Difference of Two Arrays Using Perl
(10 answers)
Closed 8 years ago.
I have two arrays ,so i want to get the similar values from both the arrays in a array.
This is array :
my #a = qw( a e c d );
my #b = qw( c d e f );
Please help me how could i get the similar values in Perl.I am new in Perl
try this easy code:
my #a = qw( a e c d );
my #b = qw( c d e f );
foreach $my(#a){
print "$my\n";
if ((grep(/$my/,#b))){
push #new,$my;
}
}
print "new----#new";
Try something like below:
use strict;
use Data::Dumper;
my #a1 = qw( a e c d );
my #b1 = qw( c d e f );
my %seen;
my #final;
#seen{#a1} = (); # hash slice
foreach my $new ( #b1 ) {
push (#final, $new ) if exists $seen{$new};
}
print Dumper(\#final);
Output:
$VAR1 = [
'c',
'd',
'e'
];
A common pattern is to map a hash for seen elements and search the other array using grep.
my #a = qw( a e c d );
my #b = qw( c d e f );
my %seen = map { $_ => 1 } #a;
my #intersection = grep { $seen{$_} } #b;
print #intersection;
Assuming the end result contains elements which are present in both the arrays:
#!/usr/bin/perl -w
use strict;
my #a = qw( a e c d );
my #b = qw( c d e f );
my #c;
foreach my $x (#a)
{
foreach my $y (#b)
{
push #c, $x if ($x eq $y);
}
}
foreach (#c) {print $_."\n"};
Output:
e
c
d
You can also try http://vti.github.io/underscore-perl a clone of underscore-js. You can do an intersection of 2 arrays -> http://vti.github.io/underscore-perl/#intersection
use Underscore;
_->intersection([1, 2, 3], [101, 2, 1, 10], [2, 1]);
# [1, 2]
I'm working with a table that looks like this
C1 C2 C3
1 a b
2 c d
4 e g
4 f h
5 x y
... ... ...
If the values in C1 are the same (in this example there is two times a 4) than I want the values of C2 and C3 to be pasted on the first line with 4 in C1 and I want to remove then the second line with 4 in C1. So at the end it should look like this
C1 C2 C3
1 a b
2 c d
4 e,f g,h
5 x y
I'm working with a perl script. I'm using while to loop through the file. I've used thing like my %seen or count in other scripts, but I'm not able to figure out how to use them know. It looks really simple to do ...
This is how my while loop looks like for the moment
while (<$DATA>) {
#columns = split
$var1 = $columns[0]
$var2 = $columns[1]
$var3 = $columns[2];
}
Use a hash to control the duplicates. I have used in my example a hash (%info) of hashes, with keys C1 and C2. Each of them contains an array reference to add the duplicated items.
use strict;
use warnings;
my %info = ();
while (<DATA>) {
my #columns = split /\s+/;
if( exists $info{ $columns[0] } ) {
push #{ $info{ $columns[0] }->{C2} }, $columns[1];
push #{ $info{ $columns[0] }->{C3} }, $columns[2];
}
else {
$info{ $columns[0] } = { C2 =>[ $columns[1] ], C3 => [ $columns[2]] }
}
}
foreach my $c1(sort {$a<=>$b} keys %info ) {
print $c1, "\t",
join(',',#{$info{$c1}->{C2}}), "\t",
join(',',#{$info{$c1}->{C3}}), "\n";
}
__DATA__
1 a b
2 c d
4 e g
4 f h
5 x y
I have this problem: Given a number of arrays (for example in Perl, or any other language):
1. (A,B,C)
2. (B,D,E,F)
3. (C,H,G)
4. (G,H)
In each array, the first element is the parent, the rest are its children. In this case, element A has two children B and C, and B has three children D, E, and F, etc. I would like to process this set of arrays, and generate a list which contains the correct order. In this case, A is the root element, so comes B and C, then under B is D, E and F, and under C is G and H, and G also has H as children (which means an element can have multiple parent). This should be the resulting array.
Important: Look at array number 3, H comes before G, even though it's a child of G in the fourth array. So there is not particular order of children in each array, but in the final result (as shown below), must have any parent before it's child/ren.
(A,B,C,D,E,F,G,H) or (A,C,B,D,E,F,G,H) or (A,B,C,G,H,D,E,F)
Would be nice to have some recursive way of creating that array, but not a requirement.
Thanks for your time..
This would be a simple post-order traversal if it wasn't for the possibility that a node has multiple parents.
To get around this, the easiest method is to assign a tier level to each node. In this case H appears on both tiers 3 and 4, and it is always the highest tier number that is required.
This code implements that design.
use strict;
use warnings;
my #rules = (
[qw/ A B C / ],
[qw/ B D E F / ],
[qw/ C H G / ],
[qw/ G H / ],
);
# Build the tree from the set of rules
#
my %tree;
for (#rules) {
my ($parent, #kids) = #$_;
$tree{$parent}{$_}++ for #kids;
}
# Find the root node. There must be exactly one node that
# doesn't appear as a child
#
my $root = do {
my #kids = map keys %$_, values %tree;
my %kids = map {$_ => 1} #kids;
my #roots = grep {not exists $kids{$_}} keys %tree;
die qq(Multiple root nodes "#roots" found) if #roots > 1;
die qq(No root nodes found) if #roots < 1;
$roots[0];
};
# Build a hash of nodes versus their tier level using a post-order
# traversal of the tree
#
my %tiers;
my $tier = 0;
traverse($root);
# Build the sorted list and show the result
#
my #sorted = sort { $tiers{$a} <=> $tiers{$b} } keys %tiers;
print "#sorted\n";
sub max {
no warnings 'uninitialized';
my ($x, $y) = #_;
$x > $y ? $x : $y;
}
sub traverse {
my ($parent) = #_;
$tier++;
my #kids = keys %{ $tree{$parent} };
if (#kids) {
traverse($_) for #kids;
}
$tiers{$parent} = max($tiers{$parent}, $tier);
$tier--;
}
output
A B C F E D G H
Edit
This works slightly more cleanly as a hash of arrays. Here is that refactor.
use strict;
use warnings;
my #rules = (
[qw/ A B C / ],
[qw/ B D E F / ],
[qw/ C H G / ],
[qw/ G H / ],
);
# Build the tree from the set of rules
#
my %tree;
for (#rules) {
my ($parent, #kids) = #$_;
$tree{$parent} = \#kids;
}
# Find the root node. There must be exactly one node that
# doesn't appear as a child
#
my $root = do {
my #kids = map #$_, values %tree;
my %kids = map {$_ => 1} #kids;
my #roots = grep {not exists $kids{$_}} keys %tree;
die qq(Multiple root nodes "#roots") if #roots > 1;
die qq(No root nodes) if #roots < 1;
$roots[0];
};
# Build a hash of nodes versus their tier level using a post-order
# traversal of the tree
#
my %tiers;
traverse($root);
# Build the sorted list and show the result
#
my #sorted = sort { $tiers{$a} <=> $tiers{$b} } keys %tiers;
print "#sorted\n";
sub max {
no warnings 'uninitialized';
my ($x, $y) = #_;
$x > $y ? $x : $y;
}
sub traverse {
my ($parent, $tier) = #_;
$tier //= 1;
my $kids = $tree{$parent};
if ($kids) {
traverse($_, $tier + 1) for #$kids;
}
$tiers{$parent} = max($tiers{$parent}, $tier);
}
The output is equivalent to the previous solution, given that there are multiple correct orderings. Note that A will always be first and H last, and A C B F G D E H is a possiblity.
This version also works, but it gives you a permutation of all correct answers, so you get correct result each time, but it may not be as your previous result (unless you have a lot of spare time...:-)).
#!/usr/bin/perl -w
use strict;
use warnings;
use Graph::Directed qw( );
my #rules = (
[qw( A B C )],
[qw( B D E F )],
[qw( C H G )],
[qw( G H )],
);
print #rules;
my $graph = Graph::Directed->new();
for (#rules) {
my $parent = shift(#$_);
for my $child (#$_) {
$graph->add_edge($parent, $child);
}
}
$graph->is_dag()
or die("Graph has a cycle--unable to analyze\n");
$graph->is_weakly_connected()
or die "Graph is not weakly connected--unable to analyze\n";
print join ' ', $graph->topological_sort(); # for eks A C B D G H E F
I have the following code
use strict;
use warnings;
use Data::Dumper;
my $s = "12 A P1
23 B P5
24 C P2
15 D P1
06 E P5 ";
my $hash = {};
my #a = split(/\n/, $s);
foreach (#a)
{
my $c = (split)[2];
my $d = (split)[1];
my $e = (split)[0];
push(#{$hash->{$c}}, $d);
}
print Dumper($hash );
I am getting the output
$VAR1 = {
'P5' => [
'B',
'E'
],
'P2' => [
'C'
],
'P1' => [
'A',
'D'
]
};
But I want the output like
$VAR1 = {
'P5' => {
'E' => '06',
'B' => '23'
},
'P2' => {
'C' => '24'
},
'P1' => {
'A' => '12',
'D' => '15'
}
};
Please help.
You need to use a hash if you want a hash as output.
No need to split three times and use postscripts, just split once and assign all variables. Also no need to initialize a scalar as an empty hash, perl will take care of that for you.
I renamed the variables for increased readability.
my $string = "12 A P1
23 B P5
24 C P2
15 D P1
06 E P5 ";
my $hash;
my #lines = split(/\n/, $string);
foreach (#lines)
{
my ($value, $key2, $key) = split;
$hash->{$key}{$key2} = $value;
}
print Dumper($hash );
Be aware that if you have multiple values with the same keys, they will overwrite each other. In that case, you'd need to push the values onto an array instead:
push #{$hash->{$key}{$key2}}, $value;
Well it's not that different from what you have. Just replace the push with a hash-assign (thank you auto-vivification):
foreach (#a)
{
my ($e, $d, $c) = split;
$hash->{$c}->{$d} = $e;
}
Additionally I have re-arranged the "split" so that it's just called once per line.