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

(-)a/C4/HoldsQueue.pm (-33 / +251 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
  MapItemsToHoldRequests($hold_requests, $available_items, $branches, $transport_cost_matrix)
635
  MapItemsToHoldRequests($hold_requests, $available_items, $branches, $transport_cost_matrix)
Lines 530-535 sub MapItemsToHoldRequests { Link Here
530
        }
767
        }
531
    }
768
    }
532
769
770
    if ( defined $transport_cost_matrix ) {
771
        my $allocations = _allocateWithTransportCostMatrix(
772
            $hold_requests,         $available_items,  $branches_to_use, $libraries,
773
            $transport_cost_matrix, \%allocated_items, \%items_by_itemnumber
774
        );
775
        for my $allocation (@$allocations) {
776
            $item_map{ $allocation->[0] } = $allocation->[1];
777
            $num_items_remaining--;
778
        }
779
        return \%item_map;
780
    }
781
533
    # group available items by branch
782
    # group available items by branch
534
    my %items_by_branch = ();
783
    my %items_by_branch = ();
535
    foreach my $item (@$available_items) {
784
    foreach my $item (@$available_items) {
Lines 540-545 sub MapItemsToHoldRequests { Link Here
540
    }
789
    }
541
    return \%item_map unless keys %items_by_branch;
790
    return \%item_map unless keys %items_by_branch;
542
791
792
    my $priority_branch = C4::Context->preference('HoldsQueuePrioritizeBranch') // 'homebranch';
793
543
    # now handle the title-level requests
794
    # now handle the title-level requests
544
    $num_items_remaining = scalar(@$available_items) - scalar(keys %allocated_items);
795
    $num_items_remaining = scalar(@$available_items) - scalar(keys %allocated_items);
545
    my $pull_branches;
796
    my $pull_branches;
Lines 553-559 sub MapItemsToHoldRequests { Link Here
553
        my ($itemnumber, $holdingbranch);
804
        my ($itemnumber, $holdingbranch);
554
805
555
        my $holding_branch_items = $items_by_branch{$pickup_branch};
806
        my $holding_branch_items = $items_by_branch{$pickup_branch};
556
        my $priority_branch = C4::Context->preference('HoldsQueuePrioritizeBranch') // 'homebranch';
557
        if ( $holding_branch_items ) {
807
        if ( $holding_branch_items ) {
558
            foreach my $item (@$holding_branch_items) {
808
            foreach my $item (@$holding_branch_items) {
559
                next unless $items_by_itemnumber{ $item->{itemnumber} }->{_object}->can_be_transferred( { to => $libraries->{ $request->{branchcode} } } );
809
                next unless $items_by_itemnumber{ $item->{itemnumber} }->{_object}->can_be_transferred( { to => $libraries->{ $request->{branchcode} } } );
Lines 573-610 sub MapItemsToHoldRequests { Link Here
573
            }
823
            }
574
            $holdingbranch = $pickup_branch;
824
            $holdingbranch = $pickup_branch;
575
        }
825
        }
576
        elsif ($transport_cost_matrix) {
577
            $pull_branches = [keys %items_by_branch];
578
            $holdingbranch = least_cost_branch( $pickup_branch, $pull_branches, $transport_cost_matrix );
579
            if ( $holdingbranch ) {
580
581
                my $holding_branch_items = $items_by_branch{$holdingbranch};
582
                foreach my $item (@$holding_branch_items) {
583
                    next if $request->{borrowerbranch} ne $item->{$priority_branch};
584
                    next unless $items_by_itemnumber{ $item->{itemnumber} }->{_object}->can_be_transferred( { to => $libraries->{ $request->{branchcode} } } );
585
586
                    # Don't fill item level holds that contravene the hold pickup policy at this time
587
                    next unless _checkHoldPolicy($item, $request);
588
589
                    # If hold itemtype is set, item's itemtype must match
590
                    next unless ( !$request->{itemtype}
591
                        || $item->{itype} eq $request->{itemtype} );
592
593
                    # If hold item_group is set, item's item_group must match
594
                    next unless (
595
                        !$request->{item_group_id}
596
                        || (   $item->{_object}->item_group
597
                            && $item->{_object}->item_group->id eq $request->{item_group_id} )
598
                    );
599
600
                    $itemnumber = $item->{itemnumber};
601
                    last;
602
                }
603
            }
604
            else {
605
                next;
606
            }
607
        }
608
826
609
        unless ($itemnumber) {
827
        unless ($itemnumber) {
610
            # not found yet, fall back to basics
828
            # not found yet, fall back to basics
(-)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