From 0b911701b7ff5606de9a694e7bfb0c1844e1fa1e Mon Sep 17 00:00:00 2001 From: Andreas Jonsson Date: Sun, 21 Jan 2024 19:47:55 +0000 Subject: [PATCH] Bug 35826: optimize on transport cost when building holds queue Signed-off-by: Kyle M Hall Signed-off-by: Martin Renvoize --- C4/HoldsQueue.pm | 284 +++++++++++++++++++++++++++++++++++++++++------ cpanfile | 1 + 2 files changed, 252 insertions(+), 33 deletions(-) diff --git a/C4/HoldsQueue.pm b/C4/HoldsQueue.pm index 5e555f4f959..703ed23129b 100644 --- a/C4/HoldsQueue.pm +++ b/C4/HoldsQueue.pm @@ -28,10 +28,12 @@ use Koha::DateUtils qw( dt_from_string ); use Koha::Hold::HoldsQueueItems; use Koha::Items; use Koha::Libraries; +use Koha::Logger; use Koha::Patrons; use List::Util qw( shuffle ); use List::MoreUtils qw( any ); +use Algorithm::Munkres qw(); our (@ISA, @EXPORT_OK); BEGIN { @@ -393,6 +395,241 @@ sub _checkHoldPolicy { } +sub _allocateWithTransportCostMatrix { + my ( + $hold_requests, $available_items, $branches_to_use, $libraries, $transport_cost_matrix, $allocated_items, + $items_by_itemnumber + ) = @_; + + my @allocated; + + my @remaining_items = grep { !exists $allocated_items->{ $_->{itemnumber} } && $_->{holdallowed} ne 'not_allowed'; } + @$available_items; + + my @requests = grep { !defined $_->{itemnumber} } @$hold_requests; + my @remaining = (); + + my $num_agents = scalar(@remaining_items); + my $num_tasks = scalar(@requests); + + return [] if $num_agents == 0 || $num_tasks == 0; + + if ( $num_tasks > $num_agents ) { + @remaining = @requests[ $num_agents - 1 .. $num_tasks - 1 ]; + @requests = @requests[ 0 .. $num_agents - 1 ]; + $num_tasks = $num_agents; + } + + my @m = map { [ (undef) x $num_tasks ] } ( 1 .. $num_agents ); + + my $inf = -1; # Initially represent infinity with a negative value. + my $max = 0; + + # If some candidate holds requests cannot be filled and there are + # hold requests remaining, we will try again a limited number of + # times. + # + # The limit is chosen arbitrarily and only servers to keep the + # asymptotic worst case to O(num_tasks³). + my $RETRIES = 8; + my $retries = $RETRIES; + my $r = 0; + +RETRY: + while (1) { + + return [] if $num_agents == 0 || $num_tasks == 0; + + if ( $num_tasks < $num_agents && @remaining ) { + # On retry, move tasks from @remaining to @requests up to + # the number of agents. + my $nr = scalar(@remaining); + my $na = $num_agents - $num_tasks; + my $nm = $nr < $na ? $nr : $na; + push @requests, ( splice @remaining, 0, $nm ); + $num_tasks += $nm; + } + + my @candidate_tasks = ( (0) x $num_tasks ); + my @candidate_agents = ( (0) x $num_agents ); + for ( my $i = 0 ; $i < $num_agents ; $i++ ) { + for ( my $j = $r ; $j < $num_tasks ; $j++ ) { + my $item = $remaining_items[$i]; + my $request = $requests[$j]; + + my $pickup_branch = $request->{branchcode} || $request->{borrowerbranch}; + my $srcbranch = $item->{holdingbranch}; + + my $cost; + + $cost = $inf unless _checkHoldPolicy( $item, $request ); + $cost = $inf + unless $items_by_itemnumber->{ $item->{itemnumber} }->{_object} + ->can_be_transferred( { to => $libraries->{ $request->{branchcode} } } ); + + # If hold itemtype is set, item's itemtype must match + $cost = $inf unless ( !$request->{itemtype} + || $item->{itype} eq $request->{itemtype} ); + + # If hold item_group is set, item's item_group must match + $cost = $inf + unless ( + !$request->{item_group_id} + || ( $item->{_object}->item_group + && $item->{_object}->item_group->id eq $request->{item_group_id} ) + ); + + if ( !defined $cost ) { + my $cell = $transport_cost_matrix->{$pickup_branch}{$srcbranch}; + + if ( !defined $cell && $pickup_branch eq $srcbranch ) { + $cost = 0; + } elsif ( !defined $cell || $cell->{disable_transfer} ) { + $cost = $inf; + } else { + $cost = $cell->{cost}; + } + } + + $m[$i][$j] = $cost; + + if ( $cost != $inf ) { + # There is at least one possible item in row $i and column $j + $candidate_tasks[$j] = 1; + $candidate_agents[$i] = 1; + } + + if ( $cost > $max ) { + $max = $cost; + } + } + } + + # Remove any item which have no finite transport cost with respect to any of the hold requests. + for ( my $i = 0, my $i0 = 0 ; $i < $num_agents ; $i++ ) { + if ( !$candidate_agents[$i] ) { + splice @m, $i - $i0, 1; + splice @remaining_items, $i - $i0, 1; + $i0++; + } + } + $num_agents = scalar(@remaining_items); + + # Remove any hold request for which there is no finite transport cost item available. + my $removed_something = 0; + for ( my $j = 0, my $j0 = 0 ; $j < $num_tasks ; $j++ ) { + if ( !$candidate_tasks[$j] ) { + for ( my $i = 0 ; $i < $num_agents ; $i++ ) { + splice @{ $m[$i] }, $j - $j0, 1; + } + splice @requests, $j - $j0, 1; + $j0++; + $removed_something = 1; + } + } + $num_tasks = scalar(@requests); + + if ( $num_agents > $num_tasks && @remaining ) { + $r = $num_tasks - 1; + next RETRY; + } + + if ( $num_tasks > $num_agents ) { + return [] if $num_agents == 0; + unshift @remaining, ( splice @requests, $num_agents ); + $num_tasks = $num_agents; + } + + return [] if $num_agents == 0 || $num_tasks == 0; + + # Substitute infinity with a cost that is higher than the total of + # any possible assignment. This ensures that any possible + # assignment will be selected before any assignment of infinite + # cost. Infinite cost assignments can be be filtered out at the + # end. + $inf = $max * $num_tasks + 1; + + for ( my $i = 0 ; $i < $num_agents ; $i++ ) { + for ( my $j = 0 ; $j < $num_tasks ; $j++ ) { + if ( $m[$i][$j] < 0 ) { + # Bias towards not allocating items to holds closer to + # the end of the queue in the queue if not all holds + # can be filled by representing infinity with + # different values. + $m[$i][$j] = $inf + ( $num_tasks - $j ); + } + } + } + + my $res = [ (undef) x $num_agents ]; + + Algorithm::Munkres::assign( \@m, $res ); + + my @unallocated = (); + @allocated = (); + for ( my $i = 0 ; $i < $num_agents ; $i++ ) { + my $j = $res->[$i]; + if ( !defined $j || $j >= $num_tasks ) { + # If the algorithm zero-pads the matrix + # (Algorithm::Munkres version 0.08) holds may be + # allocated to nonexisting items ($j >= 0). We just ignore these. + next; + } + if ( $m[$i][$j] > $max ) { + # No finite cost item was assigned to this hold. + push @unallocated, $j; + } else { + my $request = $requests[$j]; + my $item = $remaining_items[$i]; + push @allocated, [ + $item->{itemnumber}, + { + borrowernumber => $request->{borrowernumber}, + biblionumber => $request->{biblionumber}, + holdingbranch => $item->{holdingbranch}, + pickup_branch => $request->{branchcode} + || $request->{borrowerbranch}, + reserve_id => $request->{reserve_id}, + item_level => $request->{item_level_hold}, + reservedate => $request->{reservedate}, + reservenotes => $request->{reservenotes}, + } + ]; + } + } + + if ( $retries-- > 0 && @unallocated && @remaining ) { + # Remove the transport cost of unfilled holds and compact the matrix. + # Also remove the hold request from the array. + my @rs = (); + for ( my $i = 0 ; $i < $num_agents ; $i++ ) { + my $u = 0; + for ( my $j = 0 ; $j < $num_tasks ; $j++ ) { + if ( $u < scalar(@unallocated) && $unallocated[$u] == $j ) { + $u++; + } elsif ( $u > 0 ) { + $m[$i][ $j - $u ] = $m[$i][$j]; + push @rs, $requests[$j]; + } + } + } + @requests = @rs; + $num_tasks = scalar(@requests); + + $r = $num_tasks - 1; + } else { + if ( $retries == 0 && @unallocated && @remaining ) { + Koha::Logger->get->warn( + "There are available items that have not been allocated and remaining holds, but we abort trying to fill these after $RETRIES retries." + ); + } + last RETRY; + } + } + + return \@allocated; +} + =head2 MapItemsToHoldRequests MapItemsToHoldRequests($hold_requests, $available_items, $branches, $transport_cost_matrix) @@ -530,6 +767,18 @@ sub MapItemsToHoldRequests { } } + if ( defined $transport_cost_matrix ) { + my $allocations = _allocateWithTransportCostMatrix( + $hold_requests, $available_items, $branches_to_use, $libraries, + $transport_cost_matrix, \%allocated_items, \%items_by_itemnumber + ); + for my $allocation (@$allocations) { + $item_map{ $allocation->[0] } = $allocation->[1]; + $num_items_remaining--; + } + return \%item_map; + } + # group available items by branch my %items_by_branch = (); foreach my $item (@$available_items) { @@ -540,6 +789,8 @@ sub MapItemsToHoldRequests { } return \%item_map unless keys %items_by_branch; + my $priority_branch = C4::Context->preference('HoldsQueuePrioritizeBranch') // 'homebranch'; + # now handle the title-level requests $num_items_remaining = scalar(@$available_items) - scalar(keys %allocated_items); my $pull_branches; @@ -553,7 +804,6 @@ sub MapItemsToHoldRequests { my ($itemnumber, $holdingbranch); my $holding_branch_items = $items_by_branch{$pickup_branch}; - my $priority_branch = C4::Context->preference('HoldsQueuePrioritizeBranch') // 'homebranch'; if ( $holding_branch_items ) { foreach my $item (@$holding_branch_items) { next unless $items_by_itemnumber{ $item->{itemnumber} }->{_object}->can_be_transferred( { to => $libraries->{ $request->{branchcode} } } ); @@ -573,38 +823,6 @@ sub MapItemsToHoldRequests { } $holdingbranch = $pickup_branch; } - elsif ($transport_cost_matrix) { - $pull_branches = [keys %items_by_branch]; - $holdingbranch = least_cost_branch( $pickup_branch, $pull_branches, $transport_cost_matrix ); - if ( $holdingbranch ) { - - my $holding_branch_items = $items_by_branch{$holdingbranch}; - foreach my $item (@$holding_branch_items) { - next if $request->{borrowerbranch} ne $item->{$priority_branch}; - next unless $items_by_itemnumber{ $item->{itemnumber} }->{_object}->can_be_transferred( { to => $libraries->{ $request->{branchcode} } } ); - - # Don't fill item level holds that contravene the hold pickup policy at this time - next unless _checkHoldPolicy($item, $request); - - # If hold itemtype is set, item's itemtype must match - next unless ( !$request->{itemtype} - || $item->{itype} eq $request->{itemtype} ); - - # If hold item_group is set, item's item_group must match - next unless ( - !$request->{item_group_id} - || ( $item->{_object}->item_group - && $item->{_object}->item_group->id eq $request->{item_group_id} ) - ); - - $itemnumber = $item->{itemnumber}; - last; - } - } - else { - next; - } - } unless ($itemnumber) { # not found yet, fall back to basics diff --git a/cpanfile b/cpanfile index 41a4eb75336..d3c28e62d77 100644 --- a/cpanfile +++ b/cpanfile @@ -1,4 +1,5 @@ requires 'Algorithm::CheckDigits', '0.5'; +requires 'Algorithm::Munkres', '0.08'; requires 'Array::Utils', '0.5'; requires 'Auth::GoogleAuth', '1.02'; requires 'Authen::CAS::Client', '0.05'; -- 2.44.0