Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

How to remove the certain element of an object

by vagabonding electron (Hermit)
on Feb 03, 2013 at 16:23 UTC ( #1016832=perlquestion: print w/ replies, xml ) Need Help??
vagabonding electron has asked for the wisdom of the Perl Monks concerning the following question:

Dear Monks

if I will to delete the certain element of an array I could do the following:

#!/usr/bin/perl use strict; use warnings; use List::MoreUtils qw(first_index); my @array = ( 10, 15, 20, 25, 30, 20 ); my $test = 25; purge_this_one( \@array, $test ); print "@array\n"; sub purge_this_one { my $idx = first_index { $_ == $_[1] } @{$_[0]}; return @{$_[0]} if $idx == -1; # added (s.Update) splice( @{$_[0]}, $idx, 1 ); return @{$_[0]}; }

Now I try to perform the same thing in an object whose elements are another objects. As a very simple-level Perl programmer I failed miserably and I would be very grateful for your help.

Here is the code (minimal working example) with comments in the problem part:

#!/usr/bin/perl use strict; use warnings; package Person; use Moose; use constant DURATION => 100; has use_duration => ( isa => 'Int', is => 'ro', default => 1); has frequency => ( isa => 'Int', is => 'ro', default => 50 ); has population => ( handles => {obtain => 'push', release => 'shift', inventory => 'count', find => 'first_index', purge => 'delete'}, isa => 'ArrayRef[Person]', default => sub{ [] }, traits => ['Array'], is => 'ro', ); has number => ( isa => 'Int', is => 'rw', default => 0); sub need_to_go { my $self = shift; return ( rand(DURATION)+1 <= $self->frequency) ? 1 : 0; } no Moose; package main; use Data::Dumper; my $people_nr = 25; my $people = Person->new; for my $case ( 1 .. $people_nr ) { my $per = Person->new; $per->number( $case ); $people->obtain( $per ); } for my $p ( @{ $people->population } ) { if ($p->need_to_go) { # My problem is here. # I suppose to use # first_index( sub { ... }) method # and then delete or splice # but I cannot figure out what to feed # the sub { ... } with } } print Dumper $people;

Thank you in advance!

VE

Update: Improved the subroutine purge_this_one by adding the line  return @{$_[0]} if $idx == -1; after comment from sundialsvc4

Comment on How to remove the certain element of an object
Select or Download Code
Re: How to remove the certain element of an object
by tobyink (Abbot) on Feb 03, 2013 at 18:53 UTC

    Your OO design seems questionable - you seem to be using the Person class to represent individual people (good!) but also to represent collections of people/populations. Use two separate classes

    package Nation { use Moose; has population => (is => 'ro', isa => 'ArrayRef[Person]'); ...; } package Person { use Moose; has name => (is => 'ro', isa => 'Str'); ...; }

    I'm not 100% clear on exactly what you want to do. Do you want to remove people from the population when $person->need_to_go is true? If so, I'd probably do something like this:

    use List::MoreUtils qw(part); # Split population into people to keep, and people to go... my ($keep, $go) = part { !!$_->need_to_go } @{ $people->population }; # Set the population to just the people we want to keep. @{ $people->population } = @$keep;
    package Cow { use Moo; has name => (is => 'lazy', default => sub { 'Mooington' }) } say Cow->new->name

      Thank you very much tobyink ! I will work further with this.

      The background of this - I am trying to translate some Ruby scripts from this book into Perl Exploring Everyday Things ... . There is a free sampler on O'Reilly exactly with the part I am trying to translate - the direct link to the sampler seems not to working but here is the main page of the book http://shop.oreilly.com/product/0636920022626.do . It deals with the Monte Carlo simulation to model the restroom usage in an office. You observe the queues which are formed in the restroom dependent on the number of the people in the group and the number of facilities in the restroom etc.

      Well it is probably bold of me to try to do so since I do not speak Ruby at all and I am still a beginner in Perl. Otherwise I thought it is dumb just to install Ruby and copy the scripts mechanically. BTW the class Person there in the book represents the group and the individuals - I found this strange at first but I thought if adults do so I could try it too :-) Thank you for your proposal to use the separate classes!

      In fact I have a working attempt that seems to be similar to the original but not in OO-way. I am trying to do first steps in the OO-programming and I thought this exercise could be educational.

      BTW here is my "working attempt" (tried to wrap it in the spoiler to save place but failed).

      #!/usr/bin/perl use strict; use warnings; # use List::Util qw(min); use List::MoreUtils qw(first_index each_arrayref); # use Data::Dumper; my %queue; my %occupied; my %report; my %monitor; my $limit = 540; my $nr_facilities = 3; my $probability = 4/540; my $duration = 1; for ( my $y = 10; $y <= 300; $y += 10) { my @clients = ( 1 .. $y ); for my $actual_time ( 1 .. $limit ) { push @{ $monitor{$y} }, scalar keys %{ $queue{$y} }; # correction: purge the specific person. for my $id ( @clients ) { my $chance = rand; if ( $chance < $probability ) { # my $id = shift @clients; purge_this_one( \@clients, $id ); # This very person l +eaves the team. push @{ $queue{$y}{$id} }, $actual_time; # Start waiti +ng ("timestamp"). } } for my $occ_nr ( keys %{ $occupied{$y} } ) { if ( ( $actual_time - $occupied{$y}{$occ_nr}->[1] ) > $dur +ation ) { delete $occupied{$y}{$occ_nr}; # Free the facility. push @clients, $occ_nr; # Back in the team. } } while ( scalar keys %{ $queue{$y} } > 0 and # if there is a q +ueue already... scalar keys %{ $occupied{$y} } <= $nr_facilities ) # # three facilities, if any is not occupied, then ... { # who waited long? my @key_waiting = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $queue{$y}{$_}->[0] ] } keys %{ $queue{$y} }; my $turn = shift @key_waiting; # my $turn = min keys %{ $queue{$y} }; # old version o +f $turn. push @{ $queue{$y}{$turn} }, $actual_time; # End waiti +ng ("timestamp"). @{ $occupied{$y}{$turn} } = @{ $queue{$y}{$turn} }; # +Facility occupied. @{ $report{$y}{$turn} } = @{ $queue{$y}{$turn} }; # Re +porting (who waited from .. to). delete $queue{$y}{$turn}; # Purge from queue; } } } my @keys = sort {$a <=> $b} keys %monitor; my @AoA = @monitor{@keys}; my @transpose = pivot ( @AoA ); my $outfile = "output.txt"; open my $out, ">", $outfile or die "$!"; print {$out} join(';', @keys ), "\n"; print {$out} join(';', @$_ ), "\n" for @transpose; system q["C:/Program Files/R/R-2.13.0/bin/R.exe" CMD BATCH R_script.r] +; sub purge_this_one { my $idx = first_index { $_ == $_[1] } @{$_[0]}; splice( @{$_[0]}, $idx, 1 ); return @{$_[0]}; } sub pivot { my @arr = @_; my $iter = each_arrayref(@arr); my @pivot; while ( my @tuple = $iter->() ) { push @pivot, [@tuple]; } return @pivot; } # In case somebody is curious: printf "%-5s %-5s %-5s %-5s %-5s\n", 'Group', 'Nr', 'Start', 'End', 'W +ait'; for my $group ( sort {$a <=> $b} keys %report ) { for my $nr ( sort {$a <=> $b} keys %{ $report{$group} } ) { printf "%-5s %-5s %-5s %-5s %-5s\n", $group, $nr, $report{$group}{$nr}->[0], $report{$group}{$nr}->[1], $report{$group}{$nr}->[1] - $report{$group}{$nr}->[0]; } for my $nr ( sort {$a <=> $b} keys %{ $queue{$group} } ) { printf "%-5s %-5s %-5s %-5s %-5s\n", $group, $nr, $queue{$grou +p}{$nr}->[0], '', ''; } }

        I'm no Ruby expert, but I think you're misinterpreting the example in the book. @@population is a "class attribute", not an object attribute. In other words, it's a property of the "Person" class; not a property of each Person.

        Using Moose you could model it along these lines:

        package Person { use Moose; use MooseX::ClassAttribute; has name => (is => 'ro', isa => 'Str'); class_has population => (is => 'ro', isa => 'ArrayRef'); } my $bob = Person->new(name => "Robert"); push @{ Person->population }, $bob;

        Though there are many reasons to avoid class attributes. (Basically think of all the good reasons to avoid global variables, and then s/global variables/class attributes/gi.)

        package Cow { use Moo; has name => (is => 'lazy', default => sub { 'Mooington' }) } say Cow->new->name

      Dear tobyink

      thanks to your and Athanasius great help I was able to go further and make a script that seems to bring a reasonable output (if I do not miss something). Here is the script, thank you very much again and it would be great if you could comment this one too :-) :

      Thanks again!

      VE

      #! perl use strict; use warnings; use feature 'say'; package Restroom; { use Moose; has queue => ( handles => { queue_obtain => 'push', queue_release => 'shift' , queue_inventory => 'count', }, isa => 'ArrayRef[Person]', default => sub { [] }, traits => ['Array'], is => 'ro',); has facility_nr => ( isa => 'Int', is => 'rw', default => 3 ); has facilities => ( handles => { fac_open => 'push', fac_close => 'shift' , fac_count => 'count', }, isa => 'ArrayRef[Facility]', default => sub { [] }, traits => ['Array'], is => 'ro',); has returner => ( handles => {in => 'push', out => 'shift', r_nr + => 'count',}, isa => 'ArrayRef[Person]', default => sub{ [] }, traits => ['Array'], is => 'ro', ); sub initialize { my $self = shift; for ( 1 .. $self->facility_nr ) { my $facility = Facility->new(); $self->fac_open( $facility ); $facility->number($_); } } sub enter { use List::MoreUtils qw(any); my $self = shift; my $person = shift; if ( any { ! $_->occupied() } @{ $self->facilities } ) { for my $facility ( @{ $self->facilities } ) { if ( not $facility->occupied() ) { $facility->occupy( $person ); last; } } } else { $self->queue_obtain( $person ); } } sub tick { my $self = shift; for my $facility ( @{ $self->facilities } ) { $facility->tick( ); if ( $facility->ret_nr ) { $self->in($facility->stepout); } } } no Moose; } package Facility; { use Moose; has occupier => ( handles => {doit => 'push', leave => 'shift', +check => 'count',}, isa => 'ArrayRef[Person]', default => sub{ [] }, traits => ['Array'], is => 'ro', ); has duration => ( isa => 'Int', is => 'rw', default => 0, ); has number => ( isa => 'Int', is => 'rw', default => 0); has returner => ( handles => {stepin => 'push', stepout => 'shif +t', ret_nr => 'count',}, isa => 'ArrayRef[Person]', default => sub{ [] }, traits => ['Array'], is => 'ro', ); sub occupy { my $self = shift; my $person = shift; unless( $self->occupied() ) { $self->doit( $person ); #? $self->duration(1); return 1; } else { return 0; } } sub vacate { my $self = shift; my $person = $self->leave; $self->stepin( $person ); } sub tick { my $self = shift; my $occupier = $self->occupier; if ( $self->check and ( $self->duration > $occupier->[0]->use_ +duration ) ) { $self->vacate(); $self->duration(0); } elsif ( $self->check ) { $self->duration($self->duration + 1); } } sub occupied { my $self = shift; return $self->check; } } package Person; { use Moose; use constant DURATION => 540; has use_duration => ( isa => 'Int', is => 'ro', default => 1, ); has frequency => ( isa => 'Int', is => 'ro', default => 4, ); # + debug! has number => ( isa => 'Int', is => 'rw', default => 0, ); sub need_to_go { my ($self) = @_; return rand(DURATION) + 1 <= $self->frequency; } } package Team; { use Moose; has population => ( isa => 'ArrayRef[Person]', is => 'ro', traits => ['Array'], handles => { obtain => 'push', release => 's +hift', }, ); sub cull { use List::MoreUtils qw(part); my ($self) = @_; my ($need, $stay) = part { ! $_->need_to_go } @{ $self->popul +ation }; return $need // []; } sub display { use Data::Dump; my ($self, $msg) = @_; say "\n$msg\n"; dd $self; } } package main; { use constant DURATION => 540; # use List::MoreUtils qw(each_arrayref); my %data; for ( my $people_nr = 10; $people_nr <= 600; $people_nr += 10) { say $people_nr; # simply to inform in the meantime. my $rr = Restroom->new(); $rr->initialize; my $people = Team->new; for my $case ( 1 .. $people_nr ) { my $per = Person->new; $per->number( $case ); $people->obtain( $per ); } for my $t ( 1 .. DURATION ) { push @{ $data{$people_nr} }, $rr->queue_inventory; my @queue = @{ $rr->queue }; @{ $rr->queue } = (); if ( @queue ) { my $next = shift @queue; $rr->enter( $next); } # Those who do not need to go stay in the office. my @wanted = @{ $people->cull} if $people->cull; my %wanted = map{$_ =>1} @wanted; @{ $people->population} = grep(!defined $wanted{$_}, @{ $p +eople->population}); # while ( my $p = shift @wanted ) { $rr->enter( $p ); } $rr->tick; while ( $rr->r_nr ) { $people->obtain( $rr->out); } } } my @keys = sort {$a <=> $b} keys %data; my @AoA = @data{@keys}; my @transpose = pivot ( @AoA ); my $outfile = "output_OO.txt"; open my $out, ">", $outfile or die "$!"; print {$out} join(';', @keys ), "\n"; print {$out} join(';', @$_ ), "\n" for @transpose; system q["C:/Program Files/R/R-2.13.0/bin/R.exe" CMD BATCH R_scrip +t.r]; sub pivot { my @arr = @_; my $iter = each_arrayref(@arr); my @pivot; while ( my @tuple = $iter->() ) { push @pivot, [@tuple]; } return @pivot; } }
Re: How to remove the certain element of an object
by Athanasius (Monsignor) on Feb 04, 2013 at 04:08 UTC

    ++tobyink for his excellent solution. And note that the logic for removing people from the population should not appear in main, but should be encapsulated in the container class:

    #! perl use Modern::Perl; package Person { use Moose; use constant DURATION => 100; has use_duration => ( isa => 'Int', is => 'ro', default => 1, ); has frequency => ( isa => 'Int', is => 'ro', default => 50, ); has number => ( isa => 'Int', is => 'rw', default => 0, ); sub need_to_go { my ($self) = @_; return rand(DURATION) + 1 <= $self->frequency; } } package Nation { use Moose; has population => ( isa => 'ArrayRef[Person]', is => 'ro', traits => ['Array'], handles => { obtain => 'push', }, ); sub cull { use List::MoreUtils qw(part); my ($self) = @_; my ($keep, $go) = part { $_->need_to_go } @{ $self->population + }; @{ $self->population } = @$keep; } sub display { use Data::Dump; my ($self, $msg) = @_; say "\n$msg\n"; dd $self; } } package main { my $people = Nation->new; my $people_nr = 25; for my $case (0 .. $people_nr) { my $person = Person->new; $person->number($case); $people->obtain($person); } $people->display('Before:'); $people->cull; $people->display('After:'); }

    Typical output:

    Hope that helps,

    Athanasius <°(((><contra mundum Iustus alius egestas vitae, eros Piratica,

Re: How to remove the certain element of an object
by sundialsvc4 (Monsignor) on Feb 04, 2013 at 15:40 UTC

    Personally, I would reject the present purge_this_one subroutine in a code review.   I’d do it because phrasing such as $_[n], while syntactically acceptable to Perl, most certainly is not informative to me, nor to anyone else who might encounter this code in the future.   I’d have to examine each and every use of the subroutine in order to figure out either how to call it correctly or how to debug it.

    Furthermore, the code is trusting.   What if $idx is undefined (or whatever) because the element isn’t there at all?   The code doesn’t work anymore, and it doesn’t say why it doesn’t.

    Take the extra few microseconds it takes to write code that is legible, maintainable by someone other than yourself, and capable of responding at least with respect to the Hippocratic Oath if the program contains an error elsewhere.   You will be very glad that you did.

      Dear sundialsvc4

      thank you! Of course you are right. If the search element is not in the array then $idx is -1 and the subroutine just removes the last element of the array.

      A quick solution could be to add the line

      return @{$_[0]} if $idx == -1;

      above "splice"

      Here is a version which should be more readable:

      sub purge_this_one { my $aref = $_[0]; my $searched = $_[1]; my $idx = first_index { $_ == $searched } @$aref; return @$aref if $idx == -1; splice( @$aref, $idx, 1 ); return @$aref; }

      Thanks again!

      Update:Well, it is not enough since the subroutine does not tell if it does not purge anything. It should warn at least. I take it home and try to make it better. Thank you for noticing this. Update:Removed some private lyric from the original text.

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (5)
As of 2014-07-30 01:34 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (229 votes), past polls