View | Details | Raw Unified | Return to bug 35826
Collapse All | Expand All

(-)a/C4/HoldsQueue.pm (-8 / +249 lines)
Lines 28-37 use Koha::DateUtils qw( dt_from_string ); Link Here
28
use Koha::Hold::HoldsQueueItems;
28
use Koha::Hold::HoldsQueueItems;
29
use Koha::Items;
29
use Koha::Items;
30
use Koha::Libraries;
30
use Koha::Libraries;
31
use Koha::Logger;
31
use Koha::Patrons;
32
use Koha::Patrons;
32
33
33
use List::Util qw( shuffle );
34
use List::Util qw( shuffle );
34
use List::MoreUtils qw( any );
35
use List::MoreUtils qw( any );
36
use Algorithm::Munkres qw();
35
37
36
our (@ISA, @EXPORT_OK);
38
our (@ISA, @EXPORT_OK);
37
BEGIN {
39
BEGIN {
Lines 393-398 sub _checkHoldPolicy { Link Here
393
395
394
}
396
}
395
397
398
sub _allocateWithTransportCostMatrix {
399
    my (
400
        $hold_requests, $available_items, $branches_to_use, $libraries, $transport_cost_matrix, $allocated_items,
401
        $items_by_itemnumber
402
    ) = @_;
403
404
    my @allocated;
405
406
    my @remaining_items = grep { !exists $allocated_items->{ $_->{itemnumber} } && $_->{holdallowed} ne 'not_allowed'; }
407
        @$available_items;
408
409
    my @requests  = grep { !defined $_->{itemnumber} } @$hold_requests;
410
    my @remaining = ();
411
412
    my $num_agents = scalar(@remaining_items);
413
    my $num_tasks  = scalar(@requests);
414
415
    return [] if $num_agents == 0 || $num_tasks == 0;
416
417
    if ( $num_tasks > $num_agents ) {
418
        @remaining = @requests[ $num_agents - 1 .. $num_tasks - 1 ];
419
        @requests  = @requests[ 0 .. $num_agents - 1 ];
420
        $num_tasks = $num_agents;
421
    }
422
423
    my @m = map { [ (undef) x $num_tasks ] } ( 1 .. $num_agents );
424
425
    my $inf = -1;    # Initially represent infinity with a negative value.
426
    my $max = 0;
427
428
    # If some candidate holds requests cannot be filled and there are
429
    # hold requests remaining, we will try again a limited number of
430
    # times.
431
    #
432
    # The limit is chosen arbitrarily and only servers to keep the
433
    # asymptotic worst case to O(num_tasksĀ³).
434
    my $RETRIES = 8;
435
    my $retries = $RETRIES;
436
    my $r       = 0;
437
438
RETRY:
439
    while (1) {
440
441
        return [] if $num_agents == 0 || $num_tasks == 0;
442
443
        if ( $num_tasks < $num_agents && @remaining ) {
444
            # On retry, move tasks from @remaining to @requests up to
445
            # the number of agents.
446
            my $nr = scalar(@remaining);
447
            my $na = $num_agents - $num_tasks;
448
            my $nm = $nr < $na ? $nr : $na;
449
            push @requests, ( splice @remaining, 0, $nm );
450
            $num_tasks += $nm;
451
        }
452
453
        my @candidate_tasks  = ( (0) x $num_tasks );
454
        my @candidate_agents = ( (0) x $num_agents );
455
        for ( my $i = 0 ; $i < $num_agents ; $i++ ) {
456
            for ( my $j = $r ; $j < $num_tasks ; $j++ ) {
457
                my $item    = $remaining_items[$i];
458
                my $request = $requests[$j];
459
460
                my $pickup_branch = $request->{branchcode} || $request->{borrowerbranch};
461
                my $srcbranch     = $item->{holdingbranch};
462
463
                my $cost;
464
465
                $cost = $inf unless _checkHoldPolicy( $item, $request );
466
                $cost = $inf
467
                    unless $items_by_itemnumber->{ $item->{itemnumber} }->{_object}
468
                    ->can_be_transferred( { to => $libraries->{ $request->{branchcode} } } );
469
470
                # If hold itemtype is set, item's itemtype must match
471
                $cost = $inf unless ( !$request->{itemtype}
472
                    || $item->{itype} eq $request->{itemtype} );
473
474
                # If hold item_group is set, item's item_group must match
475
                $cost = $inf
476
                    unless (
477
                    !$request->{item_group_id}
478
                    || (   $item->{_object}->item_group
479
                        && $item->{_object}->item_group->id eq $request->{item_group_id} )
480
                    );
481
482
                if ( !defined $cost ) {
483
                    my $cell = $transport_cost_matrix->{$pickup_branch}{$srcbranch};
484
485
                    if ( !defined $cell && $pickup_branch eq $srcbranch ) {
486
                        $cost = 0;
487
                    } elsif ( !defined $cell || $cell->{disable_transfer} ) {
488
                        $cost = $inf;
489
                    } else {
490
                        $cost = $cell->{cost};
491
                    }
492
                }
493
494
                $m[$i][$j] = $cost;
495
496
                if ( $cost != $inf ) {
497
                    # There is at least one possible item in row $i and column $j
498
                    $candidate_tasks[$j]  = 1;
499
                    $candidate_agents[$i] = 1;
500
                }
501
502
                if ( $cost > $max ) {
503
                    $max = $cost;
504
                }
505
            }
506
        }
507
508
        # Remove any item which have no finite transport cost with respect to any of the hold requests.
509
        for ( my $i = 0, my $i0 = 0 ; $i < $num_agents ; $i++ ) {
510
            if ( !$candidate_agents[$i] ) {
511
                splice @m,               $i - $i0, 1;
512
                splice @remaining_items, $i - $i0, 1;
513
                $i0++;
514
            }
515
        }
516
        $num_agents = scalar(@remaining_items);
517
518
        # Remove any hold request for which there is no finite transport cost item available.
519
        my $removed_something = 0;
520
        for ( my $j = 0, my $j0 = 0 ; $j < $num_tasks ; $j++ ) {
521
            if ( !$candidate_tasks[$j] ) {
522
                for ( my $i = 0 ; $i < $num_agents ; $i++ ) {
523
                    splice @{ $m[$i] }, $j - $j0, 1;
524
                }
525
                splice @requests, $j - $j0, 1;
526
                $j0++;
527
                $removed_something = 1;
528
            }
529
        }
530
        $num_tasks = scalar(@requests);
531
532
        if ( $num_agents > $num_tasks && @remaining ) {
533
            $r = $num_tasks - 1;
534
            next RETRY;
535
        }
536
537
        if ( $num_tasks > $num_agents ) {
538
            return [] if $num_agents == 0;
539
            unshift @remaining, ( splice @requests, $num_agents );
540
            $num_tasks = $num_agents;
541
        }
542
543
        return [] if $num_agents == 0 || $num_tasks == 0;
544
545
        # Substitute infinity with a cost that is higher than the total of
546
        # any possible assignment.  This ensures that any possible
547
        # assignment will be selected before any assignment of infinite
548
        # cost.  Infinite cost assignments can be be filtered out at the
549
        # end.
550
        $inf = $max * $num_tasks + 1;
551
552
        for ( my $i = 0 ; $i < $num_agents ; $i++ ) {
553
            for ( my $j = 0 ; $j < $num_tasks ; $j++ ) {
554
                if ( $m[$i][$j] < 0 ) {
555
                    # Bias towards not allocating items to holds closer to
556
                    # the end of the queue in the queue if not all holds
557
                    # can be filled by representing infinity with
558
                    # different values.
559
                    $m[$i][$j] = $inf + ( $num_tasks - $j );
560
                }
561
            }
562
        }
563
564
        my $res = [ (undef) x $num_agents ];
565
566
        Algorithm::Munkres::assign( \@m, $res );
567
568
        my @unallocated = ();
569
        @allocated = ();
570
        for ( my $i = 0 ; $i < $num_agents ; $i++ ) {
571
            my $j = $res->[$i];
572
            if ( !defined $j || $j >= $num_tasks ) {
573
                # If the algorithm zero-pads the matrix
574
                # (Algorithm::Munkres version 0.08) holds may be
575
                # allocated to nonexisting items ($j >= 0).  We just ignore these.
576
                next;
577
            }
578
            if ( $m[$i][$j] > $max ) {
579
                # No finite cost item was assigned to this hold.
580
                push @unallocated, $j;
581
            } else {
582
                my $request = $requests[$j];
583
                my $item    = $remaining_items[$i];
584
                push @allocated, [
585
                    $item->{itemnumber},
586
                    {
587
                        borrowernumber => $request->{borrowernumber},
588
                        biblionumber   => $request->{biblionumber},
589
                        holdingbranch  => $item->{holdingbranch},
590
                        pickup_branch  => $request->{branchcode}
591
                            || $request->{borrowerbranch},
592
                        reserve_id   => $request->{reserve_id},
593
                        item_level   => $request->{item_level_hold},
594
                        reservedate  => $request->{reservedate},
595
                        reservenotes => $request->{reservenotes},
596
                    }
597
                ];
598
            }
599
        }
600
601
        if ( $retries-- > 0 && @unallocated && @remaining ) {
602
            # Remove the transport cost of unfilled holds and compact the matrix.
603
            # Also remove the hold request from the array.
604
            my @rs = ();
605
            for ( my $i = 0 ; $i < $num_agents ; $i++ ) {
606
                my $u = 0;
607
                for ( my $j = 0 ; $j < $num_tasks ; $j++ ) {
608
                    if ( $u < scalar(@unallocated) && $unallocated[$u] == $j ) {
609
                        $u++;
610
                    } elsif ( $u > 0 ) {
611
                        $m[$i][ $j - $u ] = $m[$i][$j];
612
                        push @rs, $requests[$j];
613
                    }
614
                }
615
            }
616
            @requests  = @rs;
617
            $num_tasks = scalar(@requests);
618
619
            $r = $num_tasks - 1;
620
        } else {
621
            if ( $retries == 0 && @unallocated && @remaining ) {
622
                Koha::Logger->get->warn(
623
                    "There are available items that have not been allocated and remaining holds, but we abort trying to fill these after $RETRIES retries."
624
                );
625
            }
626
            last RETRY;
627
        }
628
    }
629
630
    return \@allocated;
631
}
632
396
=head2 MapItemsToHoldRequests
633
=head2 MapItemsToHoldRequests
397
634
398
  my $item_map = MapItemsToHoldRequests($hold_requests, $available_items, $branches, $transport_cost_matrix)
635
  my $item_map = MapItemsToHoldRequests($hold_requests, $available_items, $branches, $transport_cost_matrix)
Lines 539-544 sub MapItemsToHoldRequests { Link Here
539
        }
776
        }
540
    }
777
    }
541
778
779
    if ( defined $transport_cost_matrix ) {
780
        my $allocations = _allocateWithTransportCostMatrix(
781
            $hold_requests,         $available_items,  $branches_to_use, $libraries,
782
            $transport_cost_matrix, \%allocated_items, \%items_by_itemnumber
783
        );
784
        for my $allocation (@$allocations) {
785
            $item_map{ $allocation->[0] } = $allocation->[1];
786
            $num_items_remaining--;
787
        }
788
        return \%item_map;
789
    }
790
542
    # group available items by branch
791
    # group available items by branch
543
    my %items_by_branch = ();
792
    my %items_by_branch = ();
544
    foreach my $item (@$available_items) {
793
    foreach my $item (@$available_items) {
Lines 569-582 sub MapItemsToHoldRequests { Link Here
569
        my $holding_branch_items = $items_by_branch{$pickup_branch};
818
        my $holding_branch_items = $items_by_branch{$pickup_branch};
570
        if ($holding_branch_items) {
819
        if ($holding_branch_items) {
571
            $holdingbranch = $pickup_branch;
820
            $holdingbranch = $pickup_branch;
572
        } elsif ($transport_cost_matrix) {
573
            # If there are items available at the pickup branch they will always be the least cost (no transfer needed) so we only check here in the case where there are none
574
            $pull_branches = [ keys %items_by_branch ];
575
            $holdingbranch = least_cost_branch( $pickup_branch, $pull_branches, $transport_cost_matrix );
576
            next
577
                unless $holdingbranch
578
                ; # If using the matrix, and nothing is least cost, it means we cannot transfer to the pickup branch for this request
579
            $holding_branch_items = $items_by_branch{$holdingbranch};
580
        }
821
        }
581
822
582
        my $priority_branch = C4::Context->preference('HoldsQueuePrioritizeBranch') // 'homebranch';
823
        my $priority_branch = C4::Context->preference('HoldsQueuePrioritizeBranch') // 'homebranch';
(-)a/cpanfile (-1 / +1 lines)
Lines 1-4 Link Here
1
requires 'Algorithm::CheckDigits', '0.5';
1
requires 'Algorithm::CheckDigits', '0.5';
2
requires 'Algorithm::Munkres', '0.08';
2
requires 'Array::Utils', '0.5';
3
requires 'Array::Utils', '0.5';
3
requires 'Auth::GoogleAuth', '1.02';
4
requires 'Auth::GoogleAuth', '1.02';
4
requires 'Authen::CAS::Client', '0.05';
5
requires 'Authen::CAS::Client', '0.05';
5
- 

Return to bug 35826