1912 lines
46 KiB
Perl
Executable file
1912 lines
46 KiB
Perl
Executable file
package Travelynx::Model::Journeys;
|
|
|
|
# Copyright (C) 2020-2023 Birte Kristina Friesel
|
|
#
|
|
# SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
use GIS::Distance;
|
|
use List::MoreUtils qw(after_incl before_incl);
|
|
|
|
use strict;
|
|
use warnings;
|
|
use 5.020;
|
|
use utf8;
|
|
|
|
use DateTime;
|
|
use JSON;
|
|
|
|
my %visibility_itoa = (
|
|
100 => 'public',
|
|
80 => 'travelynx',
|
|
60 => 'followers',
|
|
30 => 'unlisted',
|
|
10 => 'private',
|
|
);
|
|
|
|
my %visibility_atoi = (
|
|
public => 100,
|
|
travelynx => 80,
|
|
followers => 60,
|
|
unlisted => 30,
|
|
private => 10,
|
|
);
|
|
|
|
my @month_name
|
|
= (
|
|
qw(Januar Februar März April Mai Juni Juli August September Oktober November Dezember)
|
|
);
|
|
|
|
sub epoch_to_dt {
|
|
my ($epoch) = @_;
|
|
|
|
# Bugs (and user errors) may lead to undefined timestamps. Set them to
|
|
# 1970-01-01 to avoid crashing and show obviously wrong data instead.
|
|
$epoch //= 0;
|
|
|
|
return DateTime->from_epoch(
|
|
epoch => $epoch,
|
|
time_zone => 'Europe/Berlin',
|
|
locale => 'de-DE',
|
|
);
|
|
}
|
|
|
|
sub min_to_human {
|
|
my ( $self, $minutes ) = @_;
|
|
|
|
my @ret;
|
|
|
|
if ( $minutes >= 14 * 24 * 60 ) {
|
|
push( @ret, int( $minutes / ( 7 * 24 * 60 ) ) . ' Wochen' );
|
|
}
|
|
elsif ( $minutes >= 7 * 24 * 60 ) {
|
|
push( @ret, '1 Woche' );
|
|
}
|
|
$minutes %= 7 * 24 * 60;
|
|
|
|
if ( $minutes >= 2 * 24 * 60 ) {
|
|
push( @ret, int( $minutes / ( 24 * 60 ) ) . ' Tage' );
|
|
}
|
|
elsif ( $minutes >= 24 * 60 ) {
|
|
push( @ret, '1 Tag' );
|
|
}
|
|
$minutes %= 24 * 60;
|
|
|
|
if ( $minutes >= 2 * 60 ) {
|
|
push( @ret, int( $minutes / 60 ) . ' Stunden' );
|
|
}
|
|
elsif ( $minutes >= 60 ) {
|
|
push( @ret, '1 Stunde' );
|
|
}
|
|
$minutes %= 60;
|
|
|
|
if ( $minutes >= 2 ) {
|
|
push( @ret, "$minutes Minuten" );
|
|
}
|
|
elsif ($minutes) {
|
|
push( @ret, '1 Minute' );
|
|
}
|
|
|
|
if ( @ret == 0 ) {
|
|
return '0 Minuten';
|
|
}
|
|
|
|
if ( @ret == 1 ) {
|
|
return $ret[0];
|
|
}
|
|
|
|
my $last = pop(@ret);
|
|
return join( ', ', @ret ) . " und $last";
|
|
}
|
|
|
|
sub new {
|
|
my ( $class, %opt ) = @_;
|
|
|
|
return bless( \%opt, $class );
|
|
}
|
|
|
|
sub stats_cache {
|
|
my ($self) = @_;
|
|
return $self->{stats_cache};
|
|
}
|
|
|
|
# Returns (journey id, error)
|
|
# Must be called during a transaction.
|
|
# Must perform a rollback on error.
|
|
sub add {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $db = $opt{db};
|
|
my $uid = $opt{uid};
|
|
my $now = DateTime->now( time_zone => 'Europe/Berlin' );
|
|
my $dep_station = $self->{stations}
|
|
->search( $opt{dep_station}, backend_id => $opt{backend_id} );
|
|
my $arr_station = $self->{stations}
|
|
->search( $opt{arr_station}, backend_id => $opt{backend_id} );
|
|
|
|
if ( not $dep_station ) {
|
|
return ( undef, 'Unbekannter Startbahnhof' );
|
|
}
|
|
if ( not $arr_station ) {
|
|
return ( undef, 'Unbekannter Zielbahnhof' );
|
|
}
|
|
|
|
my $daily_journey_count = $db->select(
|
|
'journeys_str',
|
|
'count(*) as count',
|
|
{
|
|
user_id => $uid,
|
|
real_dep_ts => {
|
|
-between => [
|
|
$opt{rt_departure}->clone->subtract( days => 1 )->epoch,
|
|
$opt{rt_departure}->epoch
|
|
],
|
|
},
|
|
}
|
|
)->hash->{count};
|
|
|
|
if ( $daily_journey_count >= 100 ) {
|
|
return ( undef,
|
|
"In den 24 Stunden vor der angegebenen Abfahrtszeit wurden ${daily_journey_count} weitere Fahrten angetreten. Das kann nicht stimmen."
|
|
);
|
|
}
|
|
|
|
my $route_has_start = 0;
|
|
my $route_has_stop = 0;
|
|
|
|
for my $station ( @{ $opt{route} || [] } ) {
|
|
if ( $station eq $dep_station->{name}
|
|
or $station eq $dep_station->{ds100} )
|
|
{
|
|
$route_has_start = 1;
|
|
}
|
|
if ( $station eq $arr_station->{name}
|
|
or $station eq $arr_station->{ds100} )
|
|
{
|
|
$route_has_stop = 1;
|
|
}
|
|
}
|
|
|
|
my @route;
|
|
|
|
if ( not $route_has_start ) {
|
|
push(
|
|
@route,
|
|
[
|
|
$dep_station->{name},
|
|
$dep_station->{eva},
|
|
{
|
|
lat => $dep_station->{lat},
|
|
lon => $dep_station->{lon},
|
|
}
|
|
]
|
|
);
|
|
}
|
|
|
|
if ( $opt{route} ) {
|
|
my @unknown_stations;
|
|
for my $station ( @{ $opt{route} } ) {
|
|
my $station_info = $self->{stations}
|
|
->search( $station, backend_id => $opt{backend_id} );
|
|
if ($station_info) {
|
|
push(
|
|
@route,
|
|
[
|
|
$station_info->{name},
|
|
$station_info->{eva},
|
|
{
|
|
lat => $station_info->{lat},
|
|
lon => $station_info->{lon},
|
|
}
|
|
]
|
|
);
|
|
}
|
|
else {
|
|
push( @route, [ $station, undef, {} ] );
|
|
push( @unknown_stations, $station );
|
|
}
|
|
}
|
|
|
|
if ( not $opt{lax} ) {
|
|
if ( @unknown_stations == 1 ) {
|
|
return ( undef,
|
|
"Unbekannter Unterwegshalt: $unknown_stations[0]" );
|
|
}
|
|
elsif (@unknown_stations) {
|
|
return ( undef,
|
|
'Unbekannte Unterwegshalte: '
|
|
. join( ', ', @unknown_stations ) );
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( not $route_has_stop ) {
|
|
push(
|
|
@route,
|
|
[
|
|
$arr_station->{name},
|
|
$arr_station->{eva},
|
|
{
|
|
lat => $arr_station->{lat},
|
|
lon => $arr_station->{lon},
|
|
}
|
|
]
|
|
);
|
|
}
|
|
|
|
my $entry = {
|
|
user_id => $uid,
|
|
train_type => $opt{train_type},
|
|
train_line => $opt{train_line},
|
|
train_no => $opt{train_no},
|
|
train_id => 'manual',
|
|
checkin_station_id => $dep_station->{eva},
|
|
checkin_time => $now,
|
|
sched_departure => $opt{sched_departure},
|
|
real_departure => $opt{rt_departure},
|
|
checkout_station_id => $arr_station->{eva},
|
|
sched_arrival => $opt{sched_arrival},
|
|
real_arrival => $opt{rt_arrival},
|
|
checkout_time => $now,
|
|
edited => 0x3fff,
|
|
cancelled => $opt{cancelled} ? 1 : 0,
|
|
route => JSON->new->encode( \@route ),
|
|
backend_id => $opt{backend_id},
|
|
};
|
|
|
|
if ( $opt{comment} ) {
|
|
$entry->{user_data}
|
|
= JSON->new->encode( { comment => $opt{comment} } );
|
|
}
|
|
|
|
my $journey_id = undef;
|
|
eval {
|
|
$journey_id
|
|
= $db->insert( 'journeys', $entry, { returning => 'id' } )
|
|
->hash->{id};
|
|
$self->stats_cache->invalidate(
|
|
ts => $opt{rt_departure},
|
|
db => $db,
|
|
uid => $uid
|
|
);
|
|
};
|
|
|
|
if ($@) {
|
|
$self->{log}->error("add_journey($uid): $@");
|
|
return ( undef, 'add_journey failed: ' . $@ );
|
|
}
|
|
|
|
return ( $journey_id, undef );
|
|
}
|
|
|
|
sub add_from_in_transit {
|
|
my ( $self, %opt ) = @_;
|
|
my $db = $opt{db};
|
|
my $journey = $opt{journey};
|
|
|
|
delete $journey->{data};
|
|
$journey->{edited} = 0;
|
|
$journey->{checkout_time} = DateTime->now( time_zone => 'Europe/Berlin' );
|
|
|
|
return $db->insert( 'journeys', $journey, { returning => 'id' } )
|
|
->hash->{id};
|
|
}
|
|
|
|
sub update {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
my $uid = $opt{uid};
|
|
my $journey_id = $opt{id};
|
|
|
|
my $rows;
|
|
|
|
my $journey = $self->get_single(
|
|
uid => $uid,
|
|
db => $db,
|
|
journey_id => $journey_id,
|
|
with_datetime => 1,
|
|
);
|
|
|
|
eval {
|
|
if ( exists $opt{from_name} ) {
|
|
my $from_station = $self->{stations}->search( $opt{from_name} );
|
|
if ( not $from_station ) {
|
|
die("Unbekannter Startbahnhof\n");
|
|
}
|
|
$rows = $db->update(
|
|
'journeys',
|
|
{
|
|
checkin_station_id => $from_station->{eva},
|
|
edited => $journey->{edited} | 0x0004,
|
|
},
|
|
{
|
|
id => $journey_id,
|
|
}
|
|
)->rows;
|
|
}
|
|
if ( exists $opt{to_name} ) {
|
|
my $to_station = $self->{stations}->search( $opt{to_name} );
|
|
if ( not $to_station ) {
|
|
die("Unbekannter Zielbahnhof\n");
|
|
}
|
|
$rows = $db->update(
|
|
'journeys',
|
|
{
|
|
checkout_station_id => $to_station->{eva},
|
|
edited => $journey->{edited} | 0x0400,
|
|
},
|
|
{
|
|
id => $journey_id,
|
|
}
|
|
)->rows;
|
|
}
|
|
if ( exists $opt{sched_departure} ) {
|
|
$rows = $db->update(
|
|
'journeys',
|
|
{
|
|
sched_departure => $opt{sched_departure},
|
|
edited => $journey->{edited} | 0x0001,
|
|
},
|
|
{
|
|
id => $journey_id,
|
|
}
|
|
)->rows;
|
|
}
|
|
if ( exists $opt{rt_departure} ) {
|
|
$rows = $db->update(
|
|
'journeys',
|
|
{
|
|
real_departure => $opt{rt_departure},
|
|
edited => $journey->{edited} | 0x0002,
|
|
},
|
|
{
|
|
id => $journey_id,
|
|
}
|
|
)->rows;
|
|
|
|
# stats are partitioned by rt_departure -> both the cache for
|
|
# the old value (see bottom of this function) and the new value
|
|
# (here) must be invalidated.
|
|
$self->stats_cache->invalidate(
|
|
ts => $opt{rt_departure},
|
|
db => $db,
|
|
uid => $uid,
|
|
);
|
|
}
|
|
if ( exists $opt{sched_arrival} ) {
|
|
$rows = $db->update(
|
|
'journeys',
|
|
{
|
|
sched_arrival => $opt{sched_arrival},
|
|
edited => $journey->{edited} | 0x0100,
|
|
},
|
|
{
|
|
id => $journey_id,
|
|
}
|
|
)->rows;
|
|
}
|
|
if ( exists $opt{rt_arrival} ) {
|
|
$rows = $db->update(
|
|
'journeys',
|
|
{
|
|
real_arrival => $opt{rt_arrival},
|
|
edited => $journey->{edited} | 0x0200,
|
|
},
|
|
{
|
|
id => $journey_id,
|
|
}
|
|
)->rows;
|
|
}
|
|
if ( exists $opt{route} ) {
|
|
my @new_route = map { [ $_, undef, {} ] } @{ $opt{route} };
|
|
$rows = $db->update(
|
|
'journeys',
|
|
{
|
|
route => JSON->new->encode( \@new_route ),
|
|
edited => $journey->{edited} | 0x0010,
|
|
},
|
|
{
|
|
id => $journey_id,
|
|
}
|
|
)->rows;
|
|
}
|
|
if ( exists $opt{cancelled} ) {
|
|
$rows = $db->update(
|
|
'journeys',
|
|
{
|
|
cancelled => $opt{cancelled},
|
|
edited => $journey->{edited} | 0x0020,
|
|
},
|
|
{
|
|
id => $journey_id,
|
|
}
|
|
)->rows;
|
|
}
|
|
if ( exists $opt{comment} ) {
|
|
$journey->{user_data}{comment} = $opt{comment};
|
|
$rows = $db->update(
|
|
'journeys',
|
|
{
|
|
user_data => JSON->new->encode( $journey->{user_data} ),
|
|
},
|
|
{
|
|
id => $journey_id,
|
|
}
|
|
)->rows;
|
|
}
|
|
if ( not defined $rows ) {
|
|
die("Invalid update key\n");
|
|
}
|
|
};
|
|
|
|
if ($@) {
|
|
$self->{log}->error("update($journey_id): $@");
|
|
return "update($journey_id): $@";
|
|
}
|
|
if ( $rows == 1 ) {
|
|
$self->stats_cache->invalidate(
|
|
ts => $journey->{rt_departure},
|
|
db => $db,
|
|
uid => $uid,
|
|
);
|
|
return undef;
|
|
}
|
|
return "update($journey_id): did not match any journey part";
|
|
}
|
|
|
|
sub delete {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
my $journey_id = $opt{id};
|
|
my $checkin_epoch = $opt{checkin};
|
|
my $checkout_epoch = $opt{checkout};
|
|
|
|
my @journeys = $self->get(
|
|
uid => $uid,
|
|
journey_id => $journey_id
|
|
);
|
|
if ( @journeys == 0 ) {
|
|
return 'Journey not found';
|
|
}
|
|
my $journey = $journeys[0];
|
|
|
|
# Double-check (comparing both ID and action epoch) to make sure we
|
|
# are really deleting the right journey and the user isn't just
|
|
# playing around with POST requests.
|
|
if ( $journey->{id} != $journey_id
|
|
or $journey->{checkin_ts} != $checkin_epoch
|
|
or $journey->{checkout_ts} != $checkout_epoch )
|
|
{
|
|
return 'Invalid journey data';
|
|
}
|
|
|
|
my $rows;
|
|
eval {
|
|
$rows = $db->delete(
|
|
'journeys',
|
|
{
|
|
user_id => $uid,
|
|
id => $journey_id,
|
|
}
|
|
)->rows;
|
|
};
|
|
|
|
if ($@) {
|
|
$self->{log}->error("Delete($uid, $journey_id): $@");
|
|
return 'DELETE failed: ' . $@;
|
|
}
|
|
|
|
if ( $rows == 1 ) {
|
|
$self->stats_cache->invalidate(
|
|
ts => epoch_to_dt( $journey->{rt_dep_ts} ),
|
|
uid => $uid
|
|
);
|
|
return undef;
|
|
}
|
|
return sprintf( 'Deleted %d rows, expected 1', $rows );
|
|
}
|
|
|
|
# Used for undo (move journey entry to in_transit)
|
|
sub pop {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db};
|
|
my $journey_id = $opt{journey_id};
|
|
|
|
my $journey = $db->select(
|
|
'journeys',
|
|
'*',
|
|
{
|
|
user_id => $uid,
|
|
id => $journey_id
|
|
}
|
|
)->hash;
|
|
|
|
$db->delete(
|
|
'journeys',
|
|
{
|
|
user_id => $uid,
|
|
id => $journey_id
|
|
}
|
|
);
|
|
|
|
return $journey;
|
|
}
|
|
|
|
sub get {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $uid = $opt{uid};
|
|
|
|
# If get is called from inside a transaction, db
|
|
# specifies the database handle performing the transaction.
|
|
# Otherwise, we grab a fresh one.
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
|
|
my @select
|
|
= (
|
|
qw(journey_id is_iris is_hafas backend_name backend_id train_type train_line train_no checkin_ts sched_dep_ts real_dep_ts dep_eva dep_ds100 dep_name dep_lat dep_lon checkout_ts sched_arr_ts real_arr_ts arr_eva arr_ds100 arr_name arr_lat arr_lon cancelled edited route messages user_data visibility effective_visibility)
|
|
);
|
|
my %where = (
|
|
user_id => $uid,
|
|
cancelled => 0
|
|
);
|
|
my %order = (
|
|
order_by => {
|
|
-desc => 'real_dep_ts',
|
|
}
|
|
);
|
|
|
|
if ( $opt{cancelled} ) {
|
|
$where{cancelled} = 1;
|
|
}
|
|
|
|
if ( $opt{limit} ) {
|
|
$order{limit} = $opt{limit};
|
|
}
|
|
|
|
if ( $opt{sched_dep_ts} ) {
|
|
$where{sched_dep_ts} = $opt{sched_dep_ts};
|
|
}
|
|
|
|
if ( $opt{journey_id} ) {
|
|
$where{journey_id} = $opt{journey_id};
|
|
delete $where{cancelled};
|
|
}
|
|
elsif ( $opt{after} and $opt{before} ) {
|
|
$where{real_dep_ts}
|
|
= { -between => [ $opt{after}->epoch, $opt{before}->epoch, ] };
|
|
}
|
|
elsif ( $opt{after} ) {
|
|
$where{real_dep_ts} = { '>=', $opt{after}->epoch };
|
|
}
|
|
elsif ( $opt{before} ) {
|
|
$where{real_dep_ts} = { '<=', $opt{before}->epoch };
|
|
}
|
|
|
|
if ( $opt{with_polyline} ) {
|
|
push( @select, 'polyline' );
|
|
}
|
|
|
|
if ( $opt{min_visibility} ) {
|
|
if ( $visibility_atoi{ $opt{min_visibility} } ) {
|
|
$opt{min_visibility} = $visibility_atoi{ $opt{min_visibility} };
|
|
}
|
|
$where{effective_visibility} = { '>=', $opt{min_visibility} };
|
|
}
|
|
|
|
my @travels;
|
|
|
|
my $res = $db->select( 'journeys_str', \@select, \%where, \%order );
|
|
|
|
for my $entry ( $res->expand->hashes->each ) {
|
|
|
|
my $ref = {
|
|
id => $entry->{journey_id},
|
|
is_iris => $entry->{is_iris},
|
|
is_hafas => $entry->{is_hafas},
|
|
backend_name => $entry->{backend_name},
|
|
backend_id => $entry->{backend_id},
|
|
type => $entry->{train_type},
|
|
line => $entry->{train_line},
|
|
no => $entry->{train_no},
|
|
from_eva => $entry->{dep_eva},
|
|
from_ds100 => $entry->{dep_ds100},
|
|
from_name => $entry->{dep_name},
|
|
from_latlon => [ $entry->{dep_lat}, $entry->{dep_lon} ],
|
|
checkin_ts => $entry->{checkin_ts},
|
|
sched_dep_ts => $entry->{sched_dep_ts},
|
|
rt_dep_ts => $entry->{real_dep_ts},
|
|
to_eva => $entry->{arr_eva},
|
|
to_ds100 => $entry->{arr_ds100},
|
|
to_name => $entry->{arr_name},
|
|
to_latlon => [ $entry->{arr_lat}, $entry->{arr_lon} ],
|
|
checkout_ts => $entry->{checkout_ts},
|
|
sched_arr_ts => $entry->{sched_arr_ts},
|
|
rt_arr_ts => $entry->{real_arr_ts},
|
|
messages => $entry->{messages},
|
|
route => $entry->{route},
|
|
edited => $entry->{edited},
|
|
user_data => $entry->{user_data},
|
|
visibility => $entry->{visibility},
|
|
effective_visibility => $entry->{effective_visibility},
|
|
};
|
|
|
|
if ( $opt{with_visibility} ) {
|
|
$ref->{visibility_str}
|
|
= $ref->{visibility}
|
|
? $visibility_itoa{ $ref->{visibility} }
|
|
: 'default';
|
|
$ref->{effective_visibility_str}
|
|
= $visibility_itoa{ $ref->{effective_visibility} };
|
|
}
|
|
|
|
if ( $opt{with_polyline} ) {
|
|
$ref->{polyline} = $entry->{polyline};
|
|
}
|
|
|
|
if ( $opt{with_datetime} ) {
|
|
$ref->{checkin} = epoch_to_dt( $ref->{checkin_ts} );
|
|
$ref->{sched_departure}
|
|
= epoch_to_dt( $ref->{sched_dep_ts} );
|
|
$ref->{rt_departure} = epoch_to_dt( $ref->{rt_dep_ts} );
|
|
$ref->{checkout} = epoch_to_dt( $ref->{checkout_ts} );
|
|
$ref->{sched_arrival} = epoch_to_dt( $ref->{sched_arr_ts} );
|
|
$ref->{rt_arrival} = epoch_to_dt( $ref->{rt_arr_ts} );
|
|
for my $stop ( @{ $ref->{route} } ) {
|
|
for my $k (qw(rt_arr rt_dep sched_arr sched_dep)) {
|
|
if ( $stop->[2]{$k} ) {
|
|
$stop->[2]{$k} = epoch_to_dt( $stop->[2]{$k} );
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( $opt{verbose} ) {
|
|
my $rename = $self->{renamed_station};
|
|
for my $stop ( @{ $ref->{route} } ) {
|
|
if ( $stop->[0] =~ m{^Betriebsstelle nicht bekannt (\d+)$} ) {
|
|
if ( my $s
|
|
= $self->{stations}
|
|
->get_by_eva( $1, backend_id => $ref->{backend_id} ) )
|
|
{
|
|
$stop->[0] = $s->{name};
|
|
}
|
|
}
|
|
if ( $rename->{ $stop->[0] } ) {
|
|
$stop->[0] = $rename->{ $stop->[0] };
|
|
}
|
|
}
|
|
$ref->{cancelled} = $entry->{cancelled};
|
|
my @parsed_messages;
|
|
for my $message ( @{ $ref->{messages} // [] } ) {
|
|
my ( $ts, $msg ) = @{$message};
|
|
push( @parsed_messages, [ epoch_to_dt($ts), $msg ] );
|
|
}
|
|
$ref->{messages} = [ reverse @parsed_messages ];
|
|
$ref->{sched_duration}
|
|
= defined $ref->{sched_arr_ts}
|
|
? $ref->{sched_arr_ts} - $ref->{sched_dep_ts}
|
|
: undef;
|
|
$ref->{rt_duration}
|
|
= defined $ref->{rt_arr_ts}
|
|
? $ref->{rt_arr_ts} - $ref->{rt_dep_ts}
|
|
: undef;
|
|
my ( $km_polyline, $km_route, $km_beeline, $skip )
|
|
= $self->get_travel_distance($ref);
|
|
$ref->{km_route} = $km_polyline || $km_route;
|
|
$ref->{skip_route} = $km_polyline ? 0 : $skip;
|
|
$ref->{km_beeline} = $km_beeline;
|
|
$ref->{skip_beeline} = $skip;
|
|
my $kmh_divisor
|
|
= ( $ref->{rt_duration} // $ref->{sched_duration} // 999999 )
|
|
/ 3600;
|
|
$ref->{kmh_route}
|
|
= $kmh_divisor ? $ref->{km_route} / $kmh_divisor : -1;
|
|
$ref->{kmh_beeline}
|
|
= $kmh_divisor
|
|
? $ref->{km_beeline} / $kmh_divisor
|
|
: -1;
|
|
}
|
|
|
|
push( @travels, $ref );
|
|
}
|
|
|
|
return @travels;
|
|
}
|
|
|
|
sub get_single {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
$opt{cancelled} = 'any';
|
|
my @journeys = $self->get(%opt);
|
|
if ( @journeys == 0 ) {
|
|
return undef;
|
|
}
|
|
|
|
return $journeys[0];
|
|
}
|
|
|
|
sub get_latest {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
|
|
my $latest_successful = $db->select(
|
|
'journeys_str',
|
|
'*',
|
|
{
|
|
user_id => $uid,
|
|
cancelled => 0
|
|
},
|
|
{
|
|
order_by => { -desc => 'real_dep_ts' },
|
|
limit => 1
|
|
}
|
|
)->expand->hash;
|
|
|
|
if ($latest_successful) {
|
|
$latest_successful->{visibility_str}
|
|
= $latest_successful->{visibility}
|
|
? $visibility_itoa{ $latest_successful->{visibility} }
|
|
: 'default';
|
|
$latest_successful->{effective_visibility_str}
|
|
= $visibility_itoa{ $latest_successful->{effective_visibility} };
|
|
}
|
|
|
|
my $latest = $db->select(
|
|
'journeys_str',
|
|
'*',
|
|
{
|
|
user_id => $uid,
|
|
},
|
|
{
|
|
order_by => { -desc => 'journey_id' },
|
|
limit => 1
|
|
}
|
|
)->expand->hash;
|
|
|
|
if ($latest) {
|
|
$latest->{visibility_str}
|
|
= $latest->{visibility}
|
|
? $visibility_itoa{ $latest->{visibility} }
|
|
: 'default';
|
|
$latest->{effective_visibility_str}
|
|
= $visibility_itoa{ $latest->{effective_visibility} };
|
|
}
|
|
|
|
return ( $latest_successful, $latest );
|
|
}
|
|
|
|
sub get_oldest_ts {
|
|
my ( $self, %opt ) = @_;
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
|
|
my $res_h = $db->select(
|
|
'journeys_str',
|
|
['sched_dep_ts'],
|
|
{
|
|
user_id => $uid,
|
|
},
|
|
{
|
|
limit => 1,
|
|
order_by => {
|
|
-asc => 'real_dep_ts',
|
|
},
|
|
}
|
|
)->hash;
|
|
|
|
if ($res_h) {
|
|
return epoch_to_dt( $res_h->{sched_dep_ts} );
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
sub get_latest_checkout_latlon {
|
|
my ( $self, %opt ) = @_;
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
|
|
my $res_h = $db->select(
|
|
'journeys_str',
|
|
[ 'arr_lat', 'arr_lon', ],
|
|
{
|
|
user_id => $uid,
|
|
cancelled => 0
|
|
},
|
|
{
|
|
limit => 1,
|
|
order_by => { -desc => 'journey_id' }
|
|
}
|
|
)->hash;
|
|
|
|
if ( not $res_h ) {
|
|
return;
|
|
}
|
|
|
|
return $res_h->{arr_lat}, $res_h->{arr_lon};
|
|
|
|
}
|
|
|
|
sub get_latest_checkout_ids {
|
|
my ( $self, %opt ) = @_;
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
|
|
my $res_h = $db->select(
|
|
'journeys',
|
|
[ 'checkout_station_id', 'backend_id', ],
|
|
{
|
|
user_id => $uid,
|
|
cancelled => 0
|
|
},
|
|
{
|
|
limit => 1,
|
|
order_by => { -desc => 'real_departure' }
|
|
}
|
|
)->hash;
|
|
|
|
if ( not $res_h ) {
|
|
return;
|
|
}
|
|
|
|
return $res_h->{checkout_station_id}, $res_h->{backend_id};
|
|
}
|
|
|
|
sub get_latest_checkout_stations {
|
|
my ( $self, %opt ) = @_;
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
my $limit = $opt{limit} // 5;
|
|
|
|
my $res = $db->select(
|
|
'journeys_str',
|
|
[
|
|
'arr_name', 'arr_eva', 'train_id', 'backend_id',
|
|
'backend_name', 'is_hafas'
|
|
],
|
|
{
|
|
user_id => $uid,
|
|
cancelled => 0
|
|
},
|
|
{
|
|
limit => $limit,
|
|
order_by => { -desc => 'journey_id' }
|
|
}
|
|
);
|
|
|
|
if ( not $res ) {
|
|
return;
|
|
}
|
|
|
|
my @ret;
|
|
|
|
while ( my $row = $res->hash ) {
|
|
push(
|
|
@ret,
|
|
{
|
|
name => $row->{arr_name},
|
|
eva => $row->{arr_eva},
|
|
hafas => $row->{is_hafas} ? $row->{backend_name} : 0,
|
|
backend_id => $row->{backend_id},
|
|
}
|
|
);
|
|
}
|
|
|
|
return @ret;
|
|
}
|
|
|
|
sub get_nav_years {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
|
|
my $res = $db->select(
|
|
'journeys',
|
|
'distinct extract(year from real_departure) as year',
|
|
{ user_id => $uid },
|
|
{ order_by => { -asc => 'year' } }
|
|
);
|
|
|
|
my @ret;
|
|
for my $row ( $res->hashes->each ) {
|
|
push( @ret, [ $row->{year}, $row->{year} ] );
|
|
}
|
|
return @ret;
|
|
}
|
|
|
|
sub get_years {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my @years = $self->get_nav_years(%opt);
|
|
|
|
for my $year (@years) {
|
|
my $stats = $self->stats_cache->get(
|
|
uid => $opt{uid},
|
|
year => $year,
|
|
month => 0,
|
|
);
|
|
$year->[2] = $stats // {};
|
|
}
|
|
return @years;
|
|
}
|
|
|
|
sub get_months_for_year {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
my $year = $opt{year};
|
|
|
|
my $res = $db->select(
|
|
'journeys',
|
|
'distinct extract(year from real_departure) as year, extract(month from real_departure) as month',
|
|
{ user_id => $uid },
|
|
{ order_by => { -asc => 'year' } }
|
|
);
|
|
|
|
my @ret;
|
|
|
|
for my $month ( 1 .. 12 ) {
|
|
push( @ret,
|
|
[ sprintf( '%d/%02d', $year, $month ), $month_name[ $month - 1 ] ]
|
|
);
|
|
}
|
|
|
|
for my $row ( $res->hashes->each ) {
|
|
if ( $row->{year} == $year ) {
|
|
|
|
my $stats = $self->stats_cache->get(
|
|
db => $db,
|
|
uid => $uid,
|
|
year => $year,
|
|
month => $row->{month}
|
|
);
|
|
|
|
# undef -> no journeys for this month; empty hash -> no cached stats
|
|
$ret[ $row->{month} - 1 ][2] = $stats // {};
|
|
}
|
|
}
|
|
return @ret;
|
|
}
|
|
|
|
sub get_yyyymm_having_journeys {
|
|
my ( $self, %opt ) = @_;
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
my $res = $db->select(
|
|
'journeys',
|
|
"distinct to_char(real_departure, 'YYYY.MM') as yearmonth",
|
|
{ user_id => $uid },
|
|
{ order_by => { -asc => 'yearmonth' } }
|
|
);
|
|
|
|
my @ret;
|
|
for my $row ( $res->hashes->each ) {
|
|
push( @ret, [ split( qr{[.]}, $row->{yearmonth} ) ] );
|
|
}
|
|
|
|
return @ret;
|
|
}
|
|
|
|
sub generate_missing_stats {
|
|
my ( $self, %opt ) = @_;
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
my @journey_months = $self->get_yyyymm_having_journeys(
|
|
uid => $uid,
|
|
db => $db
|
|
);
|
|
my @stats_months = $self->stats_cache->get_yyyymm_having_stats(
|
|
uid => $uid,
|
|
$db => $db
|
|
);
|
|
|
|
my $stats_index = 0;
|
|
|
|
for my $journey_index ( 0 .. $#journey_months ) {
|
|
if ( $stats_index < @stats_months
|
|
and $journey_months[$journey_index][0]
|
|
== $stats_months[$stats_index][0]
|
|
and $journey_months[$journey_index][1]
|
|
== $stats_months[$stats_index][1] )
|
|
{
|
|
$stats_index++;
|
|
}
|
|
else {
|
|
my ( $year, $month ) = @{ $journey_months[$journey_index] };
|
|
$self->get_stats(
|
|
uid => $uid,
|
|
db => $db,
|
|
year => $year,
|
|
month => $month,
|
|
write_only => 1
|
|
);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub get_nav_months {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
my $filter_year = $opt{year};
|
|
my $filter_month = $opt{month};
|
|
|
|
my $selected_index = undef;
|
|
|
|
my $res = $db->select(
|
|
'journeys',
|
|
"distinct to_char(real_departure, 'YYYY.MM') as yearmonth",
|
|
{ user_id => $uid },
|
|
{ order_by => { -asc => 'yearmonth' } }
|
|
);
|
|
|
|
my @months;
|
|
for my $row ( $res->hashes->each ) {
|
|
my ( $year, $month ) = split( qr{[.]}, $row->{yearmonth} );
|
|
push( @months, [ $year, $month ] );
|
|
if ( $year eq $filter_year and $month eq $filter_month ) {
|
|
$selected_index = $#months;
|
|
}
|
|
}
|
|
|
|
# returns (previous entry, current month, next entry). if there is no
|
|
# previous or next entry, the corresponding field is undef. Previous/next
|
|
# entry is usually previous/next month, but may also have a distance of
|
|
# more than one month if there are months without travels
|
|
my @ret = ( undef, undef, undef );
|
|
|
|
$ret[1] = [
|
|
"${filter_year}/${filter_month}",
|
|
$month_name[ $filter_month - 1 ] // $filter_month
|
|
];
|
|
|
|
if ( not defined $selected_index ) {
|
|
return @ret;
|
|
}
|
|
|
|
if ( $selected_index > 0 and $months[ $selected_index - 1 ] ) {
|
|
my ( $year, $month ) = @{ $months[ $selected_index - 1 ] };
|
|
$ret[0] = [ "${year}/${month}", "${month}.${year}" ];
|
|
}
|
|
if ( $selected_index < $#months ) {
|
|
my ( $year, $month ) = @{ $months[ $selected_index + 1 ] };
|
|
$ret[2] = [ "${year}/${month}", "${month}.${year}" ];
|
|
}
|
|
|
|
return @ret;
|
|
}
|
|
|
|
sub sanity_check {
|
|
my ( $self, $journey, $lax ) = @_;
|
|
|
|
if ( defined $journey->{sched_duration}
|
|
and $journey->{sched_duration} <= 0 )
|
|
{
|
|
return
|
|
'Die geplante Dauer dieser Fahrt ist ≤ 0. Teleportation und Zeitreisen werden aktuell nicht unterstützt.';
|
|
}
|
|
if ( defined $journey->{rt_duration}
|
|
and $journey->{rt_duration} <= 0 )
|
|
{
|
|
return
|
|
'Die Dauer dieser Fahrt ist ≤ 0. Teleportation und Zeitreisen werden aktuell nicht unterstützt.';
|
|
}
|
|
if ( $journey->{sched_duration}
|
|
and $journey->{sched_duration} > 60 * 60 * 24 )
|
|
{
|
|
return 'Die Fahrt ist länger als 24 Stunden.';
|
|
}
|
|
if ( $journey->{rt_duration}
|
|
and $journey->{rt_duration} > 60 * 60 * 24 )
|
|
{
|
|
return 'Die Fahrt ist länger als 24 Stunden.';
|
|
}
|
|
if ( $journey->{kmh_route} > 500 or $journey->{kmh_beeline} > 500 ) {
|
|
return 'Fahrten mit über 500 km/h? Schön wär\'s.';
|
|
}
|
|
if ( $journey->{route} and @{ $journey->{route} } > 199 ) {
|
|
my $stop_count = @{ $journey->{route} };
|
|
return
|
|
"Die Fahrt hat $stop_count Unterwegshalte. Also ich weiß ja nicht so recht.";
|
|
}
|
|
if ( $journey->{edited} & 0x0010 and not $lax ) {
|
|
my @unknown_stations
|
|
= $self->{stations}
|
|
->grep_unknown( map { $_->[0] } @{ $journey->{route} } );
|
|
if (@unknown_stations) {
|
|
return 'Unbekannte Station(en): ' . join( ', ', @unknown_stations );
|
|
}
|
|
}
|
|
|
|
return undef;
|
|
}
|
|
|
|
sub get_travel_distance {
|
|
my ( $self, $journey ) = @_;
|
|
|
|
my $from = $journey->{from_name};
|
|
my $from_eva = $journey->{from_eva};
|
|
my $from_latlon = $journey->{from_latlon};
|
|
my $to = $journey->{to_name};
|
|
my $to_eva = $journey->{to_eva};
|
|
my $to_latlon = $journey->{to_latlon};
|
|
my $route_ref = $journey->{route};
|
|
my $polyline_ref = $journey->{polyline};
|
|
|
|
if ( not $to ) {
|
|
$self->{log}
|
|
->warn("Journey $journey->{id} has no to_name for EVA $to_eva");
|
|
}
|
|
|
|
if ( not $from ) {
|
|
$self->{log}
|
|
->warn("Journey $journey->{id} has no from_name for EVA $from_eva");
|
|
}
|
|
|
|
# Work around inconsistencies caused by a multiple EVA IDs mapping to the same station name
|
|
if (
|
|
@{ $polyline_ref // [] }
|
|
and not List::MoreUtils::any { $_->[2] and $_->[2] == $from_eva }
|
|
@{ $polyline_ref // [] }
|
|
)
|
|
{
|
|
$self->{log}->debug(
|
|
"Journey $journey->{id} from_eva ($from_eva) is not part of polyline"
|
|
);
|
|
for my $entry ( @{$route_ref} ) {
|
|
if ( $entry->[0] eq $from and $entry->[1] ) {
|
|
$from_eva = $entry->[1];
|
|
$self->{log}->debug("... setting to $from_eva");
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
if (
|
|
@{ $polyline_ref // [] }
|
|
and not List::MoreUtils::any { $_->[2] and $_->[2] == $to_eva }
|
|
@{ $polyline_ref // [] }
|
|
)
|
|
{
|
|
$self->{log}->debug(
|
|
"Journey $journey->{id} to_eva ($to_eva) is not part of polyline");
|
|
for my $entry ( @{$route_ref} ) {
|
|
if ( $entry->[0] eq $to and $entry->[1] ) {
|
|
$to_eva = $entry->[1];
|
|
$self->{log}->debug("... setting to $to_eva");
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
|
|
my $distance_polyline = 0;
|
|
my $distance_intermediate = 0;
|
|
my $geo = GIS::Distance->new();
|
|
my $distance_beeline
|
|
= $geo->distance_metal( @{$from_latlon}, @{$to_latlon} );
|
|
my @route
|
|
= after_incl { ( $_->[1] and $_->[1] == $from_eva ) or $_->[0] eq $from }
|
|
@{$route_ref};
|
|
@route
|
|
= before_incl { ( $_->[1] and $_->[1] == $to_eva ) or $_->[0] eq $to }
|
|
@route;
|
|
|
|
if (
|
|
@route < 2
|
|
or ( $route[-1][0] ne $to
|
|
and ( not $route[-1][1] or $route[-1][1] != $to_eva ) )
|
|
)
|
|
{
|
|
|
|
# I AM ERROR
|
|
return ( 0, 0, $distance_beeline );
|
|
}
|
|
|
|
my @polyline = after_incl { $_->[2] and $_->[2] == $from_eva }
|
|
@{ $polyline_ref // [] };
|
|
@polyline
|
|
= before_incl { $_->[2] and $_->[2] == $to_eva } @polyline;
|
|
|
|
# ensure that before_incl matched -- otherwise, @polyline is too long
|
|
if ( @polyline and $polyline[-1][2] == $to_eva ) {
|
|
my $prev_station = shift @polyline;
|
|
for my $station (@polyline) {
|
|
$distance_polyline += $geo->distance_metal(
|
|
$prev_station->[1], $prev_station->[0],
|
|
$station->[1], $station->[0]
|
|
);
|
|
$prev_station = $station;
|
|
}
|
|
}
|
|
|
|
if ( defined $route[0][2]{lat} and defined $route[0][2]{lon} ) {
|
|
my $prev_station = shift @route;
|
|
for my $station (@route) {
|
|
if ( defined $station->[2]{lat} and defined $station->[2]{lon} ) {
|
|
$distance_intermediate += $geo->distance_metal(
|
|
$prev_station->[2]{lat}, $prev_station->[2]{lon},
|
|
$station->[2]{lat}, $station->[2]{lon}
|
|
);
|
|
$prev_station = $station;
|
|
}
|
|
}
|
|
}
|
|
|
|
return ( $distance_polyline, $distance_intermediate, $distance_beeline );
|
|
}
|
|
|
|
sub grep_single {
|
|
my ( $self, @journeys ) = @_;
|
|
|
|
my %num_by_trip;
|
|
for my $journey (@journeys) {
|
|
if ( $journey->{from_name} and $journey->{to_name} ) {
|
|
$num_by_trip{ $journey->{from_name} . '|' . $journey->{to_name} }
|
|
+= 1;
|
|
}
|
|
}
|
|
|
|
return
|
|
grep { $num_by_trip{ $_->{from_name} . '|' . $_->{to_name} } == 1 }
|
|
@journeys;
|
|
}
|
|
|
|
sub compute_review {
|
|
my ( $self, $stats, @journeys ) = @_;
|
|
my $longest_km;
|
|
my $longest_t;
|
|
my $shortest_km;
|
|
my $shortest_t;
|
|
my $most_delayed;
|
|
my $most_delay;
|
|
my $most_undelay;
|
|
my $num_cancelled = 0;
|
|
my $num_fgr = 0;
|
|
my $num_punctual = 0;
|
|
my $message_count = 0;
|
|
my %num_by_message;
|
|
my %num_by_wrtype;
|
|
my %num_by_linetype;
|
|
my %num_by_stop;
|
|
my %num_by_trip;
|
|
|
|
if ( not $stats or not @journeys or $stats->{num_trains} == 0 ) {
|
|
return;
|
|
}
|
|
|
|
my %review;
|
|
|
|
for my $journey (@journeys) {
|
|
if ( $journey->{cancelled} ) {
|
|
$num_cancelled += 1;
|
|
next;
|
|
}
|
|
|
|
my %seen;
|
|
|
|
if ( $journey->{rt_duration} and $journey->{rt_duration} > 0 ) {
|
|
if ( not $longest_t
|
|
or $journey->{rt_duration} > $longest_t->{rt_duration} )
|
|
{
|
|
$longest_t = $journey;
|
|
}
|
|
if ( not $shortest_t
|
|
or $journey->{rt_duration} < $shortest_t->{rt_duration} )
|
|
{
|
|
$shortest_t = $journey;
|
|
}
|
|
}
|
|
|
|
if ( $journey->{km_route} ) {
|
|
if ( not $longest_km
|
|
or $journey->{km_route} > $longest_km->{km_route} )
|
|
{
|
|
$longest_km = $journey;
|
|
}
|
|
if ( not $shortest_km
|
|
or $journey->{km_route} < $shortest_km->{km_route} )
|
|
{
|
|
$shortest_km = $journey;
|
|
}
|
|
}
|
|
|
|
if ( $journey->{messages} and @{ $journey->{messages} } ) {
|
|
$message_count += 1;
|
|
for my $message ( @{ $journey->{messages} } ) {
|
|
if ( not $seen{ $message->[1] } ) {
|
|
$num_by_message{ $message->[1] } += 1;
|
|
$seen{ $message->[1] } = 1;
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( $journey->{type} ) {
|
|
$num_by_linetype{ $journey->{type} } += 1;
|
|
}
|
|
|
|
if ( $journey->{from_name} ) {
|
|
$num_by_stop{ $journey->{from_name} } += 1;
|
|
}
|
|
if ( $journey->{to_name} ) {
|
|
$num_by_stop{ $journey->{to_name} } += 1;
|
|
}
|
|
if ( $journey->{from_name} and $journey->{to_name} ) {
|
|
$num_by_trip{ $journey->{from_name} . '|' . $journey->{to_name} }
|
|
+= 1;
|
|
}
|
|
|
|
if ( $journey->{sched_dep_ts} and $journey->{rt_dep_ts} ) {
|
|
$journey->{delay_dep}
|
|
= ( $journey->{rt_dep_ts} - $journey->{sched_dep_ts} ) / 60;
|
|
}
|
|
if ( $journey->{sched_arr_ts} and $journey->{rt_arr_ts} ) {
|
|
$journey->{delay_arr}
|
|
= ( $journey->{rt_arr_ts} - $journey->{sched_arr_ts} ) / 60;
|
|
}
|
|
|
|
if ( $journey->{delay_arr} and $journey->{delay_arr} >= 60 ) {
|
|
$num_fgr += 1;
|
|
}
|
|
if ( not $journey->{delay_arr} and not $journey->{delay_dep} ) {
|
|
$num_punctual += 1;
|
|
}
|
|
|
|
if ( $journey->{delay_arr} and $journey->{delay_arr} > 0 ) {
|
|
if ( not $most_delayed
|
|
or $journey->{delay_arr} > $most_delayed->{delay_arr} )
|
|
{
|
|
$most_delayed = $journey;
|
|
}
|
|
}
|
|
|
|
if ( $journey->{rt_duration}
|
|
and $journey->{sched_duration}
|
|
and $journey->{rt_duration} > 0
|
|
and $journey->{sched_duration} > 0 )
|
|
{
|
|
my $slowdown = $journey->{rt_duration} - $journey->{sched_duration};
|
|
my $speedup = -$slowdown;
|
|
if (
|
|
not $most_delay
|
|
or $slowdown > (
|
|
$most_delay->{rt_duration} - $most_delay->{sched_duration}
|
|
)
|
|
)
|
|
{
|
|
$most_delay = $journey;
|
|
}
|
|
if (
|
|
not $most_undelay
|
|
or $speedup > (
|
|
$most_undelay->{sched_duration}
|
|
- $most_undelay->{rt_duration}
|
|
)
|
|
)
|
|
{
|
|
$most_undelay = $journey;
|
|
}
|
|
}
|
|
}
|
|
|
|
my @linetypes = sort { $b->[1] <=> $a->[1] }
|
|
map { [ $_, $num_by_linetype{$_} ] } keys %num_by_linetype;
|
|
my @stops = sort { $b->[1] <=> $a->[1] }
|
|
map { [ $_, $num_by_stop{$_} ] } keys %num_by_stop;
|
|
my @trips = sort { $b->[1] <=> $a->[1] }
|
|
map { [ $_, $num_by_trip{$_} ] } keys %num_by_trip;
|
|
|
|
my @reasons = sort { $b->[1] <=> $a->[1] }
|
|
map { [ $_, $num_by_message{$_} ] } keys %num_by_message;
|
|
|
|
$review{num_stops} = scalar @stops;
|
|
$review{km_circle} = $stats->{km_route} / 40030;
|
|
$review{km_diag} = $stats->{km_route} / 12742;
|
|
|
|
$review{trains_per_day} = sprintf( '%.1f', $stats->{num_trains} / 365 );
|
|
$review{km_route} = sprintf( '%.0f', $stats->{km_route} );
|
|
$review{km_beeline} = sprintf( '%.0f', $stats->{km_beeline} );
|
|
$review{km_circle_h} = sprintf( '%.1f', $review{km_circle} );
|
|
$review{km_diag_h} = sprintf( '%.1f', $review{km_diag} );
|
|
|
|
$review{trains_per_day} =~ tr{.}{,};
|
|
$review{km_circle_h} =~ tr{.}{,};
|
|
$review{km_diag_h} =~ tr{.}{,};
|
|
|
|
my $min_total = $stats->{min_travel_real} + $stats->{min_interchange_real};
|
|
$review{traveling_min_total} = $min_total;
|
|
$review{traveling_percentage_year}
|
|
= sprintf( "%.1f%%", $min_total * 100 / 525948.77 );
|
|
$review{traveling_percentage_year} =~ tr{.}{,};
|
|
$review{traveling_time_year} = $self->min_to_human($min_total);
|
|
|
|
if (@linetypes) {
|
|
$review{typical_type_1} = $linetypes[0][0];
|
|
}
|
|
if ( @linetypes > 1 ) {
|
|
$review{typical_type_2} = $linetypes[1][0];
|
|
}
|
|
if ( @stops >= 3 ) {
|
|
my $desc = q{};
|
|
$review{typical_stops_3} = [ $stops[0][0], $stops[1][0], $stops[2][0] ];
|
|
}
|
|
elsif ( @stops == 2 ) {
|
|
$review{typical_stops_2} = [ $stops[0][0], $stops[1][0] ];
|
|
}
|
|
$review{typical_time}
|
|
= $self->min_to_human( $stats->{min_travel_real} / $stats->{num_trains} );
|
|
$review{typical_km}
|
|
= sprintf( '%.0f', $stats->{km_route} / $stats->{num_trains} );
|
|
$review{typical_kmh} = sprintf( '%.0f',
|
|
$stats->{km_route} / ( $stats->{min_travel_real} / 60 ) );
|
|
$review{typical_delay_dep}
|
|
= sprintf( '%.0f', $stats->{delay_dep} / $stats->{num_trains} );
|
|
$review{typical_delay_dep_h}
|
|
= $self->min_to_human( $review{typical_delay_dep} );
|
|
$review{typical_delay_arr}
|
|
= sprintf( '%.0f', $stats->{delay_arr} / $stats->{num_trains} );
|
|
$review{typical_delay_arr_h}
|
|
= $self->min_to_human( $review{typical_delay_arr} );
|
|
|
|
if ($longest_t) {
|
|
$review{longest_t_time}
|
|
= $self->min_to_human( $longest_t->{rt_duration} / 60 );
|
|
$review{longest_t_type} = $longest_t->{type};
|
|
$review{longest_t_lineno} = $longest_t->{line} // $longest_t->{no};
|
|
$review{longest_t_from} = $longest_t->{from_name};
|
|
$review{longest_t_to} = $longest_t->{to_name};
|
|
$review{longest_t_id} = $longest_t->{id};
|
|
}
|
|
|
|
if ($longest_km) {
|
|
$review{longest_km_km} = sprintf( '%.0f', $longest_km->{km_route} );
|
|
$review{longest_km_type} = $longest_km->{type};
|
|
$review{longest_km_lineno} = $longest_km->{line} // $longest_km->{no};
|
|
$review{longest_km_from} = $longest_km->{from_name};
|
|
$review{longest_km_to} = $longest_km->{to_name};
|
|
$review{longest_km_id} = $longest_km->{id};
|
|
}
|
|
|
|
if ($shortest_t) {
|
|
$review{shortest_t_time}
|
|
= $self->min_to_human( $shortest_t->{rt_duration} / 60 );
|
|
$review{shortest_t_type} = $shortest_t->{type};
|
|
$review{shortest_t_lineno} = $shortest_t->{line} // $shortest_t->{no};
|
|
$review{shortest_t_from} = $shortest_t->{from_name};
|
|
$review{shortest_t_to} = $shortest_t->{to_name};
|
|
$review{shortest_t_id} = $shortest_t->{id};
|
|
}
|
|
|
|
if ($shortest_km) {
|
|
$review{shortest_km_m}
|
|
= sprintf( '%.0f', $shortest_km->{km_route} * 1000 );
|
|
$review{shortest_km_type} = $shortest_km->{type};
|
|
$review{shortest_km_lineno} = $shortest_km->{line}
|
|
// $shortest_km->{no};
|
|
$review{shortest_km_from} = $shortest_km->{from_name};
|
|
$review{shortest_km_to} = $shortest_km->{to_name};
|
|
$review{shortest_km_id} = $shortest_km->{id};
|
|
}
|
|
|
|
if ($most_delayed) {
|
|
$review{most_delayed_type} = $most_delayed->{type};
|
|
$review{most_delayed_delay_dep}
|
|
= $self->min_to_human( $most_delayed->{delay_dep} );
|
|
$review{most_delayed_delay_arr}
|
|
= $self->min_to_human( $most_delayed->{delay_arr} );
|
|
$review{most_delayed_lineno} = $most_delayed->{line}
|
|
// $most_delayed->{no};
|
|
$review{most_delayed_from} = $most_delayed->{from_name};
|
|
$review{most_delayed_to} = $most_delayed->{to_name};
|
|
$review{most_delayed_id} = $most_delayed->{id};
|
|
}
|
|
|
|
if ($most_delay) {
|
|
$review{most_delay_type} = $most_delay->{type};
|
|
$review{most_delay_delay_dep} = $most_delay->{delay_dep};
|
|
$review{most_delay_delay_arr} = $most_delay->{delay_arr};
|
|
$review{most_delay_sched_time}
|
|
= $self->min_to_human( $most_delay->{sched_duration} / 60 );
|
|
$review{most_delay_real_time}
|
|
= $self->min_to_human( $most_delay->{rt_duration} / 60 );
|
|
$review{most_delay_delta}
|
|
= $self->min_to_human(
|
|
( $most_delay->{rt_duration} - $most_delay->{sched_duration} )
|
|
/ 60 );
|
|
$review{most_delay_lineno} = $most_delay->{line} // $most_delay->{no};
|
|
$review{most_delay_from} = $most_delay->{from_name};
|
|
$review{most_delay_to} = $most_delay->{to_name};
|
|
$review{most_delay_id} = $most_delay->{id};
|
|
}
|
|
|
|
if ($most_undelay) {
|
|
$review{most_undelay_type} = $most_undelay->{type};
|
|
$review{most_undelay_delay_dep} = $most_undelay->{delay_dep};
|
|
$review{most_undelay_delay_arr} = $most_undelay->{delay_arr};
|
|
$review{most_undelay_sched_time}
|
|
= $self->min_to_human( $most_undelay->{sched_duration} / 60 );
|
|
$review{most_undelay_real_time}
|
|
= $self->min_to_human( $most_undelay->{rt_duration} / 60 );
|
|
$review{most_undelay_delta}
|
|
= $self->min_to_human(
|
|
( $most_undelay->{sched_duration} - $most_undelay->{rt_duration} )
|
|
/ 60 );
|
|
$review{most_undelay_lineno} = $most_undelay->{line}
|
|
// $most_undelay->{no};
|
|
$review{most_undelay_from} = $most_undelay->{from_name};
|
|
$review{most_undelay_to} = $most_undelay->{to_name};
|
|
$review{most_undelay_id} = $most_undelay->{id};
|
|
}
|
|
|
|
$review{issue_percent}
|
|
= sprintf( '%.0f%%', $message_count * 100 / $stats->{num_trains} );
|
|
for my $i ( 0 .. 2 ) {
|
|
if ( $reasons[$i] ) {
|
|
my $p = 'issue' . ( $i + 1 );
|
|
$review{"${p}_count"} = $reasons[$i][1];
|
|
$review{"${p}_text"} = $reasons[$i][0];
|
|
}
|
|
}
|
|
|
|
$review{cancel_count} = $num_cancelled;
|
|
$review{fgr_percent} = $num_fgr * 100 / $stats->{num_trains};
|
|
$review{fgr_percent_h} = sprintf( '%.1f%%', $review{fgr_percent} );
|
|
$review{fgr_percent_h} =~ tr{.}{,};
|
|
$review{punctual_percent} = $num_punctual * 100 / $stats->{num_trains};
|
|
$review{punctual_percent_h}
|
|
= sprintf( '%.1f%%', $review{punctual_percent} );
|
|
$review{punctual_percent_h} =~ tr{.}{,};
|
|
|
|
my $top_trip_count = 0;
|
|
my $single_trip_count = 0;
|
|
for my $i ( 0 .. 3 ) {
|
|
if ( $trips[$i] ) {
|
|
my ( $from, $to ) = split( qr{[|]}, $trips[$i][0] );
|
|
my $found = 0;
|
|
for my $j ( 0 .. $#{ $review{top_trips} } ) {
|
|
if ( $review{top_trips}[$j][0] eq $to
|
|
and $review{top_trips}[$j][2] eq $from )
|
|
{
|
|
$review{top_trips}[$j][1] = '↔';
|
|
$found = 1;
|
|
last;
|
|
}
|
|
}
|
|
if ( not $found ) {
|
|
push( @{ $review{top_trips} }, [ $from, '→', $to ] );
|
|
}
|
|
$top_trip_count += $trips[$i][1];
|
|
}
|
|
}
|
|
|
|
for my $trip (@trips) {
|
|
if ( $trip->[1] == 1 ) {
|
|
$single_trip_count += 1;
|
|
if ( @{ $review{single_trips} // [] } < 3 ) {
|
|
push(
|
|
@{ $review{single_trips} },
|
|
[ split( qr{[|]}, $trip->[0] ) ]
|
|
);
|
|
}
|
|
}
|
|
}
|
|
|
|
$review{top_trip_count} = $top_trip_count;
|
|
$review{top_trip_percent_h}
|
|
= sprintf( '%.1f%%', $top_trip_count * 100 / $stats->{num_trains} );
|
|
$review{top_trip_percent_h} =~ tr{.}{,};
|
|
|
|
$review{single_trip_count} = $single_trip_count;
|
|
$review{single_trip_percent_h}
|
|
= sprintf( '%.1f%%', $single_trip_count * 100 / $stats->{num_trains} );
|
|
$review{single_trip_percent_h} =~ tr{.}{,};
|
|
|
|
return \%review;
|
|
}
|
|
|
|
sub compute_stats {
|
|
my ( $self, @journeys ) = @_;
|
|
my $km_route = 0;
|
|
my $km_beeline = 0;
|
|
my $min_travel_sched = 0;
|
|
my $min_travel_real = 0;
|
|
my $delay_dep = 0;
|
|
my $delay_arr = 0;
|
|
my $interchange_real = 0;
|
|
my $num_trains = 0;
|
|
my $num_journeys = 0;
|
|
my @inconsistencies;
|
|
|
|
my $next_departure = 0;
|
|
my $next_id;
|
|
my $next_train;
|
|
|
|
for my $journey (@journeys) {
|
|
$num_trains++;
|
|
$km_route += $journey->{km_route};
|
|
$km_beeline += $journey->{km_beeline};
|
|
if ( $journey->{sched_duration}
|
|
and $journey->{sched_duration} > 0 )
|
|
{
|
|
$min_travel_sched += $journey->{sched_duration} / 60;
|
|
}
|
|
if ( $journey->{rt_duration} and $journey->{rt_duration} > 0 ) {
|
|
$min_travel_real += $journey->{rt_duration} / 60;
|
|
}
|
|
if ( $journey->{sched_dep_ts} and $journey->{rt_dep_ts} ) {
|
|
$delay_dep
|
|
+= ( $journey->{rt_dep_ts} - $journey->{sched_dep_ts} ) / 60;
|
|
}
|
|
if ( $journey->{sched_arr_ts} and $journey->{rt_arr_ts} ) {
|
|
$delay_arr
|
|
+= ( $journey->{rt_arr_ts} - $journey->{sched_arr_ts} ) / 60;
|
|
}
|
|
|
|
# Note that journeys are sorted from recent to older entries
|
|
if ( $journey->{rt_arr_ts}
|
|
and $next_departure
|
|
and $next_departure - $journey->{rt_arr_ts} < ( 60 * 60 ) )
|
|
{
|
|
if ( $next_departure - $journey->{rt_arr_ts} < 0 ) {
|
|
push(
|
|
@inconsistencies,
|
|
{
|
|
conflict => {
|
|
train => $journey->{type} . ' '
|
|
. ( $journey->{line} // $journey->{no} ),
|
|
arr => epoch_to_dt( $journey->{rt_arr_ts} )
|
|
->strftime('%d.%m.%Y %H:%M'),
|
|
id => $journey->{id},
|
|
},
|
|
ignored => {
|
|
train => $next_train,
|
|
dep => epoch_to_dt($next_departure)
|
|
->strftime('%d.%m.%Y %H:%M'),
|
|
id => $next_id,
|
|
},
|
|
}
|
|
);
|
|
}
|
|
else {
|
|
$interchange_real
|
|
+= ( $next_departure - $journey->{rt_arr_ts} ) / 60;
|
|
}
|
|
}
|
|
else {
|
|
$num_journeys++;
|
|
}
|
|
$next_departure = $journey->{rt_dep_ts};
|
|
$next_id = $journey->{id};
|
|
$next_train
|
|
= $journey->{type} . ' ' . ( $journey->{line} // $journey->{no} ),;
|
|
}
|
|
my $ret = {
|
|
km_route => $km_route,
|
|
km_beeline => $km_beeline,
|
|
num_trains => $num_trains,
|
|
num_journeys => $num_journeys,
|
|
min_travel_sched => $min_travel_sched,
|
|
min_travel_real => $min_travel_real,
|
|
min_interchange_real => $interchange_real,
|
|
delay_dep => $delay_dep,
|
|
delay_arr => $delay_arr,
|
|
inconsistencies => \@inconsistencies,
|
|
};
|
|
for my $key (
|
|
qw(min_travel_sched min_travel_real min_interchange_real delay_dep delay_arr)
|
|
)
|
|
{
|
|
my $strf_key = $key . '_strf';
|
|
my $value = $ret->{$key};
|
|
$ret->{$strf_key} = q{};
|
|
if ( $ret->{$key} < 0 ) {
|
|
$ret->{$strf_key} .= '-';
|
|
$value *= -1;
|
|
}
|
|
$ret->{$strf_key} .= sprintf( '%02d:%02d', $value / 60, $value % 60 );
|
|
}
|
|
return $ret;
|
|
}
|
|
|
|
sub get_stats {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
if ( $opt{cancelled} ) {
|
|
$self->{log}
|
|
->warn('get_journey_stats called with illegal option cancelled => 1');
|
|
return {};
|
|
}
|
|
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
my $year = $opt{year} // 0;
|
|
my $month = $opt{month} // 0;
|
|
|
|
# Assumption: If the stats cache contains an entry it is up-to-date.
|
|
# -> Cache entries must be explicitly invalidated whenever the user
|
|
# checks out of a train or manually edits/adds a journey.
|
|
|
|
if (
|
|
not $opt{write_only}
|
|
and not $opt{review}
|
|
and my $stats = $self->stats_cache->get(
|
|
uid => $uid,
|
|
db => $db,
|
|
year => $year,
|
|
month => $month
|
|
)
|
|
)
|
|
{
|
|
return $stats;
|
|
}
|
|
|
|
my $interval_start = DateTime->new(
|
|
time_zone => 'Europe/Berlin',
|
|
year => 2000,
|
|
month => 1,
|
|
day => 1,
|
|
hour => 0,
|
|
minute => 0,
|
|
second => 0,
|
|
);
|
|
|
|
# I wonder if people will still be traveling by train in the year 3000
|
|
my $interval_end = $interval_start->clone->add( years => 1000 );
|
|
|
|
if ( $opt{year} and $opt{month} ) {
|
|
$interval_start->set(
|
|
year => $opt{year},
|
|
month => $opt{month}
|
|
);
|
|
$interval_end = $interval_start->clone->add( months => 1 );
|
|
}
|
|
elsif ( $opt{year} ) {
|
|
$interval_start->set( year => $opt{year} );
|
|
$interval_end = $interval_start->clone->add( years => 1 );
|
|
}
|
|
|
|
my @journeys = $self->get(
|
|
uid => $uid,
|
|
cancelled => 0,
|
|
verbose => 1,
|
|
with_polyline => 1,
|
|
after => $interval_start,
|
|
before => $interval_end
|
|
);
|
|
my $stats = $self->compute_stats(@journeys);
|
|
|
|
$self->stats_cache->add(
|
|
uid => $uid,
|
|
db => $db,
|
|
year => $year,
|
|
month => $month,
|
|
stats => $stats
|
|
);
|
|
|
|
if ( $opt{review} ) {
|
|
my @cancelled_journeys = $self->get(
|
|
uid => $uid,
|
|
cancelled => 1,
|
|
verbose => 1,
|
|
after => $interval_start,
|
|
before => $interval_end
|
|
);
|
|
return ( $stats,
|
|
$self->compute_review( $stats, @journeys, @cancelled_journeys ) );
|
|
}
|
|
|
|
return $stats;
|
|
}
|
|
|
|
sub get_latest_dest_ids {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
|
|
if (
|
|
my ( $id, $backend_id ) = $self->{in_transit}->get_checkout_ids(
|
|
uid => $uid,
|
|
db => $db
|
|
)
|
|
)
|
|
{
|
|
return ( $id, $backend_id );
|
|
}
|
|
|
|
return $self->get_latest_checkout_ids(
|
|
uid => $uid,
|
|
db => $db
|
|
);
|
|
}
|
|
|
|
# Returns a listref of {eva, name} hashrefs for the specified backend.
|
|
sub get_connection_targets {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $uid = $opt{uid};
|
|
my $threshold = $opt{threshold}
|
|
// DateTime->now( time_zone => 'Europe/Berlin' )->subtract( months => 4 );
|
|
my $db = $opt{db} //= $self->{pg}->db;
|
|
my $min_count = $opt{min_count} // 3;
|
|
my $dest_id = $opt{eva};
|
|
|
|
if ( $opt{destination_name} ) {
|
|
return {
|
|
eva => $opt{eva},
|
|
name => $opt{destination_name}
|
|
};
|
|
}
|
|
|
|
my $backend_id = $opt{backend_id};
|
|
|
|
if ( not $dest_id ) {
|
|
( $dest_id, $backend_id ) = $self->get_latest_dest_ids(%opt);
|
|
}
|
|
|
|
if ( not $dest_id ) {
|
|
return;
|
|
}
|
|
|
|
my $dest_ids = [
|
|
$dest_id,
|
|
$self->{stations}->get_meta(
|
|
eva => $dest_id,
|
|
backend_id => $backend_id,
|
|
)
|
|
];
|
|
|
|
my $res = $db->select(
|
|
'journeys',
|
|
'count(checkout_station_id) as count, checkout_station_id as dest',
|
|
{
|
|
user_id => $uid,
|
|
checkin_station_id => $dest_ids,
|
|
real_departure => { '>', $threshold },
|
|
backend_id => $opt{backend_id},
|
|
},
|
|
{
|
|
group_by => ['checkout_station_id'],
|
|
order_by => { -desc => 'count' }
|
|
}
|
|
);
|
|
my @destinations
|
|
= $res->hashes->grep( sub { shift->{count} >= $min_count } )
|
|
->map( sub { shift->{dest} } )->each;
|
|
@destinations = $self->{stations}->get_by_evas(
|
|
backend_id => $opt{backend_id},
|
|
evas => [@destinations]
|
|
);
|
|
return @destinations;
|
|
}
|
|
|
|
sub update_visibility {
|
|
my ( $self, %opt ) = @_;
|
|
|
|
my $uid = $opt{uid};
|
|
my $db = $opt{db} // $self->{pg}->db;
|
|
|
|
my $visibility;
|
|
|
|
if ( $opt{visibility} and $visibility_atoi{ $opt{visibility} } ) {
|
|
$visibility = $visibility_atoi{ $opt{visibility} };
|
|
}
|
|
|
|
$db->update(
|
|
'journeys',
|
|
{ visibility => $visibility },
|
|
{
|
|
user_id => $uid,
|
|
id => $opt{id}
|
|
}
|
|
);
|
|
}
|
|
|
|
1;
|