25.85KiB; Perl | 2019-04-28 04:15:00+02 | Statements 842 | SLOC 984
1
package Ged2site::Display::graphs;
2
3
use strict;
4
use warnings;
5
use POSIX;
6
use DateTime::Locale;
7
use DateTime::Format::Natural;
8
use Statistics::LineFit;
9
use Statistics::Lite;
10
use HTML::TagCloud;
11
12
# Display some information about the family
13
14
use Ged2site::Display;
15
16
our @ISA = ('Ged2site::Display');
17
18
use constant BUCKETYEARS => 5;
19
use constant BUCKETDISTANCE => 5;
20
our $date_parser;
21
our $dfn;
22
23
# TODO: age of people dying vs. year (is that a good idea?)
24
#	Plot average distance between place of spouse's birth against year of marriage
25
#	Distance betweeen parents' birth and death places and each child birth and death places (the coloured lines)
26
27
our $mapper = {
28
	'ageatdeath' => \&_ageatdeath,
29
	'birthmonth' => \&_birthmonth,
30
	'deathmonth' => \&_deathmonth,
31
	'marriagemonth' => \&_marriagemonth,
32
	'infantdeaths' => \&_infantdeaths,
33
	'firstborn' => \&_firstborn,
34
	'sex' => \&_sex,
35
	'ageatmarriage' => \&_ageatmarriage,
36
	'dist' => \&_dist,
37
	'distcount' => \&_distcount,
38
	'ageatfirstchild' => \&_ageatfirstchild,
39
	'ageatlastchild' => \&_ageatlastchild,
40
	'familysizetime' => \&_familysizetime,
41
	'motherchildren' => \&_motherchildren,
42
	'percentagedying' => \&_percentagedying,
43
	'namecloud' => \&_namecloud,
44
};
45
46
sub html {
47
	my $self = shift;
48
	my %args = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
49
50
	my $info = $self->{_info};
51
	my $allowed = {
52
		'page' => 'graphs',
53
		'graph' => qr/^[a-z]+$/,
54
		'lang' => qr/^[A-Z][A-Z]/i,
55
		'lint_content' => qr/^\d$/,
56
	};
57
	my %params = %{$info->params({ allow => $allowed })};
58
59
	my $updated = $args{'people'}->updated();
60
61
	if((!scalar(keys %params)) || !defined($params{'graph'})) {
62
		# Display the list of graphs
63
		return $self->SUPER::html(updated => $updated);
64
	}
65
66
	if($mapper->{$params{'graph'}}) {
67
		my $rc = $mapper->{$params{'graph'}}->($self, \%args);
68
		$rc->{'updated'} = $updated;
69
		return $self->SUPER::html($rc);
70
	}
71
72
	return $self->SUPER::html(updated => $updated);
73
}
74
75
# Creates the datapoints for two graphs for age of death against year of death.
76
# One graph for women and one for men
77
sub _ageatdeath
78
{
79
	my $self = shift;
80
	my $args = shift;
81
82
	my ($datapoints, $bestfit, $samples);
83
84
	for my $sex('M', 'F') {
85
		local $args->{'sex'} = $sex;
86
		if(my $rc = $self->_ageatdeathbysex($args)) {
87
			$datapoints->{$sex} = $rc->{'datapoints'};
88
			if($rc->{'bestfit'}) {
89
				$bestfit->{$sex} = $rc->{'bestfit'};
90
			}
91
			$samples->{$sex} = $rc->{'samples'};
92
		}
93
	}
94
95
	return { datapoints => $datapoints, bestfit => $bestfit, samples => $samples };
96
}
97
98
sub _ageatdeathbysex
99
{
100
	my $self = shift;
101
	my $args = shift;
102
103
	my $people = $args->{'people'};
104
	my $sex = $args->{'sex'};
105
106
	my %counts;
107
	my %totals;
108
109
	foreach my $person($people->selectall_hash()) {
110
		next if($person->{'sex'} ne $sex);
111
		if($person->{'dob'} && $person->{'dod'}) {
112
			my $dob = $person->{'dob'};
113
			my $yob;
114
			if($dob =~ /^(\d{3,4})\/\d{2}\/\d{2}$/) {
115
				$dob =~ tr/\//-/;
116
				$yob = $1;
117
			} else {
118
				next;
119
			}
120
			# next if($yob >= 1930);
121
			my $dod = $person->{'dod'};
122
			my $yod;
123
			if($dod =~ /^(\d{3,4})\/\d{2}\/\d{2}$/) {
124
				$yod = $1;
125
			} else {
126
				next;
127
			}
128
			next if($yod < 1840);
129
			my $age = $yod - $yob;
130
			next if ($age < 20);
131
			$yod -= $yod % BUCKETYEARS;
132
			if($counts{$yod}) {
133
				$counts{$yod}++;
134
				$totals{$yod} += $yod - $yob;
135
			} else {
136
				$counts{$yod} = 1;
137
				$totals{$yod} = $yod - $yob;
138
			}
139
		}
140
	}
141
142
	my $datapoints;
143
	my(@x, @y, @samples);
144
145
	foreach my $bucket(sort keys %counts) {
146
		# next if((!defined($datapoints)) && ($counts{$bucket} == 0));
147
		my $average = $totals{$bucket} / $counts{$bucket};
148
		$average = floor($average);
149
150
		$datapoints .= "{ label: \"$bucket\", y: $average },\n";
151
		push @x, $bucket;
152
		push @y, $average;
153
		push @samples, { bucket => ("$bucket-" . ($bucket + BUCKETYEARS - 1)), size => $counts{$bucket} };
154
	}
155
	my $lf = Statistics::LineFit->new();
156
	if($lf->setData(\@x, \@y)) {
157
		@y = $lf->predictedYs();
158
		my $x = shift @x;
159
		my $y = shift @y;
160
		my $bestfit = "{ label: \"$x\", y: $y },\n";
161
		while($x = shift @x) {
162
			$y = shift @y;
163
			if($x[0]) {
164
				$bestfit .= "{ label: \"$x\", y: $y, markerSize: 1 },\n";
165
			} else {
166
				$bestfit .= "{ label: \"$x\", y: $y },\n";
167
			}
168
		}
169
		return { datapoints => $datapoints, bestfit => $bestfit, samples => \@samples };
170
	}
171
172
	return { datapoints => $datapoints, samples => \@samples };
173
}
174
175
sub _birthmonth
176
{
177
	my $self = shift;
178
	my $args = shift;
179
180
	my $people = $args->{'people'};
181
	my @counts = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
182
	foreach my $person($people->selectall_hash()) {
183
		if(my $dob = $person->{'dob'}) {
184
			if($dob =~ /^\d{3,4}\/(\d{2})\/\d{2}$/) {
185
				$counts[$1 - 1]++;
186
			}
187
		}
188
	}
189
190
	my $locale;
191
	if($self->{'_lingua'}) {
192
		if(my $language = $self->{'_lingua'}->language_code_alpha2()) {
193
			$locale = $language;
194
		}
195
	}
196
	if(!defined($locale)) {
197
		$locale = 'en';
198
	}
199
200
	my $datapoints;
201
	my $index = 0;
202
	my $dtl = DateTime::Locale->load($locale);
203
204
	while($index < 12) {
205
		my $month = @{$dtl->month_format_wide()}[$index];
206
		$datapoints .= "{ label: \"$month\", y: " . $counts[$index] . " },\n";
207
		$index++;
208
	}
209
210
	return { datapoints => $datapoints };
211
}
212
213
sub _marriagemonth
214
{
215
	my $self = shift;
216
	my $args = shift;
217
218
	my $people = $args->{'people'};
219
	my @counts = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
220
	foreach my $person($people->selectall_hash()) {
221
		if($person->{'marriages'}) {
222
			foreach my $dom(split(/----/, $person->{'marriages'})) {
223
				if($dom =~ /^(.+?)-/) {
224
					$dom = $1;	# use the first marriage
225
				}
226
				if($dom =~ /^\d{3,4}\/(\d{2})\/\d{2}$/) {
227
					$counts[$1 - 1]++;
228
				}
229
			}
230
		}
231
	}
232
233
	my $locale;
234
	if($self->{'_lingua'}) {
235
		if(my $language = $self->{'_lingua'}->language_code_alpha2()) {
236
			$locale = $language;
237
		}
238
	}
239
	if(!defined($locale)) {
240
		$locale = 'en';
241
	}
242
243
	my $datapoints;
244
	my $index = 0;
245
	my $dtl = DateTime::Locale->load($locale);
246
247
	while($index < 12) {
248
		my $month = @{$dtl->month_format_wide()}[$index];
249
		$datapoints .= "{ label: \"$month\", y: " . $counts[$index] . " },\n";
250
		$index++;
251
	}
252
253
	return { datapoints => $datapoints };
254
}
255
256
sub _deathmonth
257
{
258
	my $self = shift;
259
	my $args = shift;
260
261
	my $people = $args->{'people'};
262
	my @counts = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
263
	foreach my $person($people->selectall_hash()) {
264
		if(my $dod = $person->{'dod'}) {
265
			if($dod =~ /^\d{3,4}\/(\d{2})\/\d{2}$/) {
266
				$counts[$1 - 1]++;
267
			}
268
		}
269
	}
270
271
	my $locale;
272
	if($self->{'_lingua'}) {
273
		if(my $language = $self->{'_lingua'}->language_code_alpha2()) {
274
			$locale = $language;
275
		}
276
	}
277
	if(!defined($locale)) {
278
		$locale = 'en';
279
	}
280
281
	my $datapoints;
282
	my $index = 0;
283
	my $dtl = DateTime::Locale->load($locale);
284
285
	while($index < 12) {
286
		my $month = @{$dtl->month_format_wide()}[$index];
287
		$datapoints .= "{ label: \"$month\", y: " . $counts[$index] . " },\n";
288
		$index++;
289
	}
290
291
	return { datapoints => $datapoints };
292
}
293
294
sub _infantdeaths
295
{
296
	my $self = shift;
297
	my $args = shift;
298
299
	my %infantdeaths;
300
	my %totals;
301
	my $people = $args->{'people'};
302
303
	foreach my $person($people->selectall_hash()) {
304
		if($person->{'dob'} && $person->{'dod'}) {
305
			my $dob = $person->{'dob'};
306
			my $yob;
307
			if($dob =~ /^(\d{3,4})\/\d{2}\/\d{2}$/) {
308
				$dob =~ tr/\//-/;
309
				$yob = $1;
310
			} elsif($dob =~ /^\d{3,4}$/) {
311
				$yob = $dob;
312
			} else {
313
				next;
314
			}
315
			next if($yob < 1600);
316
			next if($yob > 2000);
317
			my $dod = $person->{'dod'};
318
			my $yod;
319
			if($dod =~ /^(\d{3,4})\/\d{2}\/\d{2}$/) {
320
				$yod = $1;
321
			} elsif($dod =~ /^\d{3,4}$/) {
322
				$yod = $dod;
323
			} else {
324
				next;
325
			}
326
			my $age = $yod - $yob;
327
			$yob -= $yob % BUCKETYEARS;
328
329
			if($totals{$yob}) {
330
				$totals{$yob}++;
331
			} else {
332
				$totals{$yob} = 1;
333
			}
334
			if($age <= 5) {
335
				if($infantdeaths{$yob}) {
336
					$infantdeaths{$yob}++;
337
				} else {
338
					$infantdeaths{$yob} = 1;
339
				}
340
			}
341
		}
342
	}
343
344
	my $datapoints;
345
346
	foreach my $bucket(sort keys %totals) {
347
		if(($totals{$bucket} >= 5) && $infantdeaths{$bucket}) {	# Good data size
348
			my $percentage = floor(($infantdeaths{$bucket} * 100) / $totals{$bucket});
349
			$datapoints .= "{ label: \"$bucket\", y: $percentage },\n";
350
		} elsif(defined($datapoints)) {
351
			$datapoints .= "{ label: \"$bucket\", y: null },\n";
352
		}
353
	}
354
355
	return { datapoints => $datapoints };
356
}
357
358
sub _firstborn
359
{
360
	my $self = shift;
361
	my $args = shift;
362
	my %months;
363
364
	my $people = $args->{'people'};
365
366
	$dfn ||= DateTime::Format::Natural->new();
367
	my $max;
368
	foreach my $person($people->selectall_hash()) {
369
		if($person->{'children'} && $person->{'marriages'}) {
370
			my $dom = $person->{'marriages'};
371
			if($dom =~ /^(.+?)-/) {
372
				$dom = $1;	# use the first marriage
373
			}
374
			my $eldest;
375
			CHILD: foreach my $child(split(/----/, $person->{'children'})) {
376
				if($child =~ /page=people&entry=([IP]\d+)"/) {
377
					$child = $people->fetchrow_hashref({ entry => $1 });
378
					my $dob = $child->{'dob'};
379
					next CHILD unless($dob);
380
					if($dob =~ /^(\d{3,4})\/(\d{2})\/(\d{2})$/) {
381
						$dob = "$3/$2/$1";
382
					} else {
383
						next CHILD;
384
					}
385
					if(defined($eldest)) {
386
						my $candidate = $self->_date_to_datetime($dob);
387 1
						if($candidate < $eldest) {
388
							$eldest = $candidate;
389
						}
390
					} else {
391
						$eldest = $self->_date_to_datetime($dob);
392
					}
393
				}
394
			}
395
			if(defined($eldest)) {
396
				my $d = $eldest->subtract_datetime($self->_date_to_datetime($dom));
397
				my $months = $d->months() + ($d->years() * 12) - 1;
398
				$months{$months}++;
399
				if((!defined($max)) || ($months > $max)) {
400
					$max = $months;
401
				}
402
			}
403
		}
404
	}
405
406
	my $datapoints;
407
408
	foreach my $month(0..$max) {
409
		if($months{$month}) {
410
			$datapoints .= "{ label: \"$month\", y: $months{$month} },\n";
411
		} else {
412
			$datapoints .= "{ label: \"$month\", y: 0 },\n";
413
		}
414
	}
415
416
	return { datapoints => $datapoints };
417
}
418
419
sub _sex
420
{
421
	my $self = shift;
422
	my $args = shift;
423
424
	my %totals;
425
	my %mcounts;
426
	my %fcounts;
427
428
	my $people = $args->{'people'};
429
430
	foreach my $person($people->selectall_hash()) {
431
		next if($person->{'sex'} !~ /[MF]/);
432
		next if(!(defined($person->{'dob'})));
433
434
		my $dob = $person->{'dob'};
435
		my $yob;
436
		if($dob =~ /^(\d{3,4})\/\d{2}\/\d{2}$/) {
437
			$dob =~ tr/\//-/;
438
			$yob = $1;
439
		} elsif($dob =~ /^\d{3,4}$/) {
440
			$yob = $dob;
441
		} else {
442
			next;
443
		}
444
		$yob -= $yob % BUCKETYEARS;
445
446
		if($person->{'sex'} eq 'M') {
447
			if($mcounts{$yob}) {
448
				$mcounts{$yob}++;
449
			} else {
450
				$mcounts{$yob} = 1;
451
			}
452
		} else {
453
			if($fcounts{$yob}) {
454
				$fcounts{$yob}++;
455
			} else {
456
				$fcounts{$yob} = 1;
457
			}
458
		}
459
		if($totals{$yob}) {
460
			$totals{$yob}++;
461
		} else {
462
			$totals{$yob} = 1;
463
		}
464
	}
465
466
	my $mdatapoints;
467
	my $fdatapoints;
468
469
	foreach my $bucket(sort keys %totals) {
470
		if(($totals{$bucket} >= 25) && defined($fcounts{$bucket}) && defined($mcounts{$bucket})) {
471
			my $percentage = $mcounts{$bucket} * 100 / $totals{$bucket};
472
			$mdatapoints .= "{ label: \"$bucket\", y: $percentage },\n";
473
474
			$percentage = $fcounts{$bucket} * 100 / $totals{$bucket};
475
			$fdatapoints .= "{ label: \"$bucket\", y: $percentage },\n";
476
		} elsif(defined($mdatapoints)) {
477
			$mdatapoints .= "{ label: \"$bucket\", y: null },\n";
478
			$fdatapoints .= "{ label: \"$bucket\", y: null },\n";
479
		}
480
	}
481
482
	return { mdatapoints => $mdatapoints, fdatapoints => $fdatapoints };
483
}
484
485
sub _ageatmarriage
486
{
487
	my $self = shift;
488
	my $args = shift;
489
490
	my %mcounts;
491
	my %mtotals;
492
	my %fcounts;
493
	my %ftotals;
494
	my %mentries;
495
	my %fentries;
496
497
	my $people = $args->{'people'};
498
499
	foreach my $person($people->selectall_hash()) {
500
		if($person->{'dob'} && $person->{'marriages'}) {
501
			my $dob = $person->{'dob'};
502
			my $yob;
503
			if($dob =~ /^(\d{3,4})\/\d{2}\/\d{2}$/) {
504
				$dob =~ tr/\//-/;
505
				$yob = $1;
506
			} elsif($dob =~ /^\d{3,4}$/) {
507
				$yob = $dob;
508
			} else {
509
				next;
510
			}
511
			next if($yob < 1600);
512
			my $dom = $person->{'marriages'};
513
			if($dom =~ /^(.+?)-/) {
514
				$dom = $1;	# use the first marriage
515
			}
516
			my $yom;
517
			if($dom =~ /^(\d{3,4})\/\d{2}\/\d{2}$/) {
518
				$yom = $1;
519
			} elsif($dom =~ /^\d{3,4}$/) {
520
				$yom = $dom;
521
			} else {
522
				next;
523
			}
524
			my $age = $yom - $yob;
525
			$yom -= $yom % BUCKETYEARS;
526
527
			if($person->{'sex'} eq 'M') {
528
				if($mcounts{$yom}) {
529
					$mcounts{$yom}++;
530
					push @{$mentries{$yom}}, $person->{'entry'};
531
				} else {
532
					$mcounts{$yom} = 1;
533
					@{$mentries{$yom}} = ($person->{'entry'});
534
				}
535
				if($mtotals{$yom}) {
536
					$mtotals{$yom} += $age;
537
				} else {
538
					$mtotals{$yom} = $age;
539
				}
540
			} else {
541
				if($fcounts{$yom}) {
542
					$fcounts{$yom}++;
543
					push @{$fentries{$yom}}, $person->{'entry'};
544
				} else {
545
					$fcounts{$yom} = 1;
546
					@{$fentries{$yom}} = ($person->{'entry'});
547
				}
548
				if($ftotals{$yom}) {
549
					$ftotals{$yom} += $age;
550
				} else {
551
					$ftotals{$yom} = $age;
552
				}
553
			}
554
		}
555
	}
556
557
	my $mdatapoints;
558
	my $fdatapoints;
559
560
	foreach my $bucket(keys %mcounts) {
561
		if(!defined($fcounts{$bucket})) {
562
			$fcounts{$bucket} = 0;
563
		}
564
	}
565
	foreach my $bucket(keys %fcounts) {
566
		if(!defined($mcounts{$bucket})) {
567
			$mcounts{$bucket} = 0;
568
		}
569
	}
570
571
	foreach my $bucket(sort { $a <=> $b } keys %mcounts) {
572
		if($mcounts{$bucket}) {
573
			my $average = floor($mtotals{$bucket} / $mcounts{$bucket});
574
575
			my $tooltip = "\"<span style=\\\"color:#F08080\\\">Male (average age {y}, sample size $mcounts{$bucket}):</span> ";
576
			foreach my $entry(@{$mentries{$bucket}}) {
577
				my $husband = $people->fetchrow_hashref({ entry => $entry });
578
				$tooltip .= '<br>' . $husband->{'title'};
579
			}
580
			$tooltip .= '"';
581
			$mdatapoints .= "{ label: \"$bucket\", y: $average, toolTipContent: $tooltip },\n";
582
		} elsif($mdatapoints) {
583
			$mdatapoints .= "{ label: \"$bucket\", y: null },\n";
584
		}
585
	}
586
	foreach my $bucket(sort { $a <=> $b } keys %fcounts) {
587
		if($fcounts{$bucket}) {
588
			my $average = floor($ftotals{$bucket} / $fcounts{$bucket});
589
590
			my $tooltip = "\"<span style=\\\"color:#20B2AA\\\">Female (average age {y}, sample size $fcounts{$bucket}):</span> ";
591
			foreach my $entry(@{$fentries{$bucket}}) {
592
				my $wife = $people->fetchrow_hashref({ entry => $entry });
593
				$tooltip .= '<br>' . $wife->{'title'};
594
			}
595
			$tooltip .= '"';
596
			$fdatapoints .= "{ label: \"$bucket\", y: $average, toolTipContent: $tooltip },\n";
597
		} elsif($fdatapoints) {
598
			$fdatapoints .= "{ label: \"$bucket\", y: null },\n";
599
		}
600
	}
601
602
	return { mdatapoints => $mdatapoints, fdatapoints => $fdatapoints };
603
}
604
605
sub _dist
606
{
607
	my $self = shift;
608
	my $args = shift;
609
610
	my $people = $args->{'people'};
611
612
	my $units = 'K';
613
614
	if($self->{'_lingua'}) {
615
		if(my $country = $self->{'_lingua'}->country()) {
616
			if(($country eq 'us') || ($country eq 'uk')) {
617
				$units = 'M';
618
			}
619
		}
620
	}
621
622
	my %totals;
623
	my %counts;
624
	my %dists;
625
	foreach my $person($people->selectall_hash()) {
626
		next unless($person->{'birth_coords'} && $person->{'death_coords'} && $person->{'dob'});
627
		my $dob = $person->{'dob'};
628
		my $yob;
629
		if($dob =~ /^(\d{3,4})/) {
630
			$yob = $1;
631
		} else {
632
			next;
633
		}
634
		$yob -= $yob % BUCKETYEARS;
635
636
		my ($blat, $blong) = split(/,/, $person->{'birth_coords'});
637
		my ($dlat, $dlong) = split(/,/, $person->{'death_coords'});
638
639
		$counts{$yob}++;
640
641
		if((($blat - $dlat) >= 1e-6) && (($blong - $dlong) >= 1e-6)) {
642
			my $dist = ::distance($blat, $blong, $dlat, $dlong, $units);
643
			$totals{$yob} += $dist;
644
			push @{$dists{$yob}}, $dist;
645
		} elsif(!defined($totals{$yob})) {
646
			$totals{$yob} = 0;
647
			push @{$dists{$yob}}, 0;
648
		} else {
649
			push @{$dists{$yob}}, 0;
650
		}
651
	}
652
653
	my $datapoints;
654
655
	foreach my $bucket(sort keys %counts) {
656
		next if(!defined($counts{$bucket}));
657
		if($counts{$bucket} >= 10) {
658
			my $average;
659
			if(defined($dists{$bucket})) {
660
				# Dispence with any people who moved more than 3/4 of
661
				# a standard deviation, since they are likely to bias the
662
				# data rather heavily.  For example one family of 4
663
				# who emigrate thousands of miles will have an unduly large
664
				# effect, especially if the data size is very small
665
				my %info = Statistics::Lite::statshash(@{$dists{$bucket}});
666
				# print "$bucket:\n", join(',', @{$dists{$bucket}}), "\n",
667
					# Statistics::Lite::statsinfo(@{$dists{$bucket}}), "\n";
668
				my $limit = $info{'mean'} + ($info{'stddev'} * (1 / 4));
669
				# print "\tLimit: $limit\n";
670
				my $count;
671
				my $total;
672
				foreach my $d(@{$dists{$bucket}}) {
673
					if($d <= $limit) {
674
						$count++;
675
						$total += $d;
676
						# print "\tAdding $d\n";
677
					}
678
				}
679
				if($count) {
680
					$average = floor($total / $count);
681
				}
682
			} else {
683
				$average = floor($totals{$bucket} / $counts{$bucket});
684
			}
685
686
			if(defined($average)) {
687
				$datapoints .= "{ label: \"$bucket\", y: $average },\n";
688
			} else {
689
				$datapoints .= "{ label: \"$bucket\", y: 0 },\n";
690
			}
691
		} elsif($datapoints) {
692
			$datapoints .= "{ label: \"$bucket\", y: null },\n";
693
		}
694
	}
695
696
	if(!defined($datapoints)) {
697
		return { error => 'No birth and/or death location data has been recorded' };
698
	}
699
700
	return { datapoints => $datapoints, units => ($units eq 'K') ? 'Kilometres' : 'Miles' };
701
}
702
703
sub _distcount
704
{
705
	my $self = shift;
706
	my $args = shift;
707
708
	my $units = 'K';
709
710
	if($self->{'_lingua'}) {
711
		if(my $country = $self->{'_lingua'}->country()) {
712
			if(($country eq 'us') || ($country eq 'uk')) {
713
				$units = 'M';
714
			}
715
		}
716
	}
717
718
	my $people = $args->{'people'};
719
	my %counts;
720
	foreach my $person($people->selectall_hash()) {
721
		next unless($person->{'birth_coords'} && $person->{'death_coords'});
722
		my $dist;
723
		if($person->{'birth_coords'} eq $person->{'death_coords'}) {
724
			$dist = 0;
725
		} else {
726
			my ($blat, $blong) = split(/,/, $person->{'birth_coords'});
727
			my ($dlat, $dlong) = split(/,/, $person->{'death_coords'});
728
729
			$dist = floor(::distance($blat, $blong, $dlat, $dlong, $units));
730
		}
731
		my $bucket = $dist - ($dist % BUCKETDISTANCE);
732
		$counts{$bucket}++;
733
	}
734
735
	my $datapoints;
736
737
	foreach my $bucket(sort { $a <=> $b } keys %counts) {
738
		if($counts{$bucket}) {
739
			my $count = $counts{$bucket};
740
741
			$datapoints .= "{ label: \"$bucket\", y: $count, markerSize: 1 },\n";
742
		} elsif($datapoints) {
743
			$datapoints .= "{ label: \"$bucket\", y: null },\n";
744
		}
745
	}
746
747
	return { datapoints => $datapoints, units => ($units eq 'K') ? 'Kilometres' : 'Miles' };
748
}
749
750
sub _ageatfirstchild
751
{
752
	my $self = shift;
753
	my $args = shift;
754
	my %mtotals;
755
	my %mcounts;
756
	my %ftotals;
757
	my %fcounts;
758
759
	my $people = $args->{'people'};
760
761
	$dfn ||= DateTime::Format::Natural->new();
762
	foreach my $person($people->selectall_hash()) {
763
		if($person->{'dob'} && $person->{'children'}) {
764
			my $dob = $person->{'dob'};
765
			my $yob;
766
			if($dob =~ /^(\d{3,4})/) {
767
				$yob = $1;
768
			} else {
769
				next;
770
			}
771
			my $bucket = $yob - ($yob % BUCKETYEARS);
772
773
			my $firstborn;
774
			CHILD: foreach my $child(split(/----/, $person->{'children'})) {
775
				if($child =~ /page=people&entry=([IP]\d+)"/) {
776
					$child = $people->fetchrow_hashref({ entry => $1 });
777
					my $cdob = $child->{'dob'};
778
					next CHILD unless($cdob);
779
					if($cdob =~ /^(\d{3,4})/) {
780
						my $cyob = $1;
781 1
						if((!defined($firstborn)) || ($cyob < $firstborn)) {
782
							$firstborn = $cyob;
783
						}
784
					}
785
				}
786
			}
787
			if(defined($firstborn)) {
788
				my $age = $firstborn - $yob;
789
				if($person->{'sex'} eq 'M') {
790
					$mtotals{$bucket} += $age;
791
					$mcounts{$bucket}++;
792
				} else {
793
					$ftotals{$bucket} += $age;
794
					$fcounts{$bucket}++;
795
				}
796
			}
797
		}
798
	}
799
800
	my $mdatapoints;
801
	my $fdatapoints;
802
803
	foreach my $bucket(sort keys %mcounts) {
804
		if($mcounts{$bucket} >= 5) {
805
			my $average = ceil($mtotals{$bucket} / $mcounts{$bucket});
806
			$mdatapoints .= "{ label: \"$bucket\", y: $average },\n";
807
		} elsif($mdatapoints) {
808
			$mdatapoints .= "{ label: \"$bucket\", y: null },\n";
809
		}
810
	}
811
	foreach my $bucket(sort keys %fcounts) {
812
		if($fcounts{$bucket} >= 5) {
813
			my $average = ceil($ftotals{$bucket} / $fcounts{$bucket});
814
			$fdatapoints .= "{ label: \"$bucket\", y: $average },\n";
815
		} elsif($fdatapoints) {
816
			$fdatapoints .= "{ label: \"$bucket\", y: null },\n";
817
		}
818
	}
819
820
	return { mdatapoints => $mdatapoints, fdatapoints => $fdatapoints };
821
}
822
823
sub _ageatlastchild
824
{
825
	my $self = shift;
826
	my $args = shift;
827
	my %mtotals;
828
	my %mcounts;
829
	my %ftotals;
830
	my %fcounts;
831
832
	my $people = $args->{'people'};
833
834
	$dfn ||= DateTime::Format::Natural->new();
835
	foreach my $person($people->selectall_hash()) {
836
		if($person->{'dob'} && $person->{'children'}) {
837
			my $dob = $person->{'dob'};
838
			my $yob;
839
			if($dob =~ /^(\d{3,4})/) {
840
				$yob = $1;
841
			} else {
842
				next;
843
			}
844
			my $bucket = $yob - ($yob % BUCKETYEARS);
845
846
			my $lastborn;
847
			CHILD: foreach my $child(split(/----/, $person->{'children'})) {
848
				if($child =~ /page=people&entry=([IP]\d+)"/) {
849
					$child = $people->fetchrow_hashref({ entry => $1 });
850
					my $cdob = $child->{'dob'};
851
					next CHILD unless($cdob);
852
					if($cdob =~ /^(\d{3,4})/) {
853
						my $cyob = $1;
854 1
						if((!defined($lastborn)) || ($cyob > $lastborn)) {
855
							$lastborn = $cyob;
856
						}
857
					}
858
				}
859
			}
860
			if(defined($lastborn)) {
861
				my $age = $lastborn - $yob;
862
				if($person->{'sex'} eq 'M') {
863
					$mtotals{$bucket} += $age;
864
					$mcounts{$bucket}++;
865
				} else {
866
					$ftotals{$bucket} += $age;
867
					$fcounts{$bucket}++;
868
				}
869
			}
870
		}
871
	}
872
873
	my $mdatapoints;
874
	my $fdatapoints;
875
876
	foreach my $bucket(sort keys %mcounts) {
877
		if($mcounts{$bucket} >= 5) {
878
			my $average = ceil($mtotals{$bucket} / $mcounts{$bucket});
879
			$mdatapoints .= "{ label: \"$bucket\", y: $average },\n";
880
		} elsif($mdatapoints) {
881
			$mdatapoints .= "{ label: \"$bucket\", y: null },\n";
882
		}
883
	}
884
	foreach my $bucket(sort keys %fcounts) {
885
		if($fcounts{$bucket} >= 5) {
886
			my $average = ceil($ftotals{$bucket} / $fcounts{$bucket});
887
			$fdatapoints .= "{ label: \"$bucket\", y: $average },\n";
888
		} elsif($fdatapoints) {
889
			$fdatapoints .= "{ label: \"$bucket\", y: null },\n";
890
		}
891
	}
892
893
	return { mdatapoints => $mdatapoints, fdatapoints => $fdatapoints };
894
}
895
896
sub _motherchildren
897
{
898
	my $self = shift;
899
	my $args = shift;
900
901
	my %counts;
902
903
	my $people = $args->{'people'};
904
905
	foreach my $person($people->selectall_hash({ 'sex' => 'F' })) {
906
		if($person->{'children'} && $person->{'dob'}) {
907
			my $dob = $person->{'dob'};
908
			if($dob =~ /^(\d{3,4})\/\d{2}\/\d{2}$/) {
909
				next if($1 < 1820);
910
			} else {
911
				next;
912
			}
913
			my $count;
914
			foreach my $child(split(/----/, $person->{'children'})) {
915
				$count++;
916
			}
917
			if($count) {
918
				$counts{$count}++;
919
			}
920
		}
921
	}
922
923
	my $datapoints;
924
925
	foreach my $col(sort { $a <=> $b } keys %counts) {
926
		$datapoints .= "{ label: \"$col\", y: $counts{$col} },\n";
927
	}
928
929
	return { datapoints => $datapoints };
930
}
931
932
sub _familysizetime
933
{
934
	my $self = shift;
935
	my $args = shift;
936
937
	my %totals;
938
	my %counts;
939
940
	my $people = $args->{'people'};
941
	$dfn ||= DateTime::Format::Natural->new();
942
943
	foreach my $person($people->selectall_hash({ 'sex' => 'F' })) {
944
		my $count;
945
		my $eldest;
946
		CHILD: foreach my $child(split(/----/, $person->{'children'})) {
947
			if($child =~ /page=people&entry=([IP]\d+)"/) {
948
				$child = $people->fetchrow_hashref({ entry => $1 });
949
				my $dob = $child->{'dob'};
950
				next CHILD unless($dob);
951
				if($dob =~ /^(\d{3,4})\/(\d{2})\/(\d{2})$/) {
952
					$dob = "$3/$2/$1";
953
				} else {
954
					next CHILD;
955
				}
956
				if(defined($eldest)) {
957
					my $candidate = $self->_date_to_datetime($dob);
958
					if($candidate < $eldest) {
959
						$eldest = $candidate;
960
					}
961
				} else {
962
					$eldest = $self->_date_to_datetime($dob);
963
				}
964
				$count++;
965
			}
966
		}
967
		if(defined($eldest)) {
968
			my $yob = $eldest->year();
969
			my $bucket = $yob - ($yob % BUCKETYEARS);
970
			$totals{$bucket} += $count;
971
			$counts{$bucket}++;
972
		}
973
	}
974
975
	my $datapoints;
976
977
	foreach my $bucket(sort keys %totals) {
978
		if($counts{$bucket} >= 5) {
979
			my $average = $totals{$bucket} / $counts{$bucket};
980
			$average = floor($average);
981
982
			$datapoints .= "{ label: \"$bucket\", y: $average },\n";
983
		} elsif(defined($datapoints)) {
984
			$datapoints .= "{ label: \"$bucket\", y: null },\n";
985
		}
986
	}
987
988
	return { datapoints => $datapoints };
989
}
990
991
# What percentage of the adults alive die in a given 5-year period?
992
# One graph for women and one for men
993
sub _percentagedying
994
{
995
	my $self = shift;
996
	my $args = shift;
997
998
	my $datapoints;
999
1000
	for my $sex('M', 'F') {
1001
		local $args->{'sex'} = $sex;
1002
		if(my $rc = $self->_percentagedyingbysex($args)) {
1003
			$datapoints->{$sex} = $rc->{'datapoints'};
1004
		}
1005
	}
1006
1007
	return { datapoints => $datapoints };
1008
}
1009
1010
sub _percentagedyingbysex
1011
{
1012
	my $self = shift;
1013
	my $args = shift;
1014
1015
	my $people = $args->{'people'};
1016
	my $sex = $args->{'sex'};
1017
1018
	my %numberalive;
1019
	my %numberdying;
1020
1021
	my $year = DateTime->today()->year();
1022
1023
	foreach my $person($people->selectall_hash()) {
1024
		next if($person->{'sex'} ne $sex);
1025
		my $yob;
1026
		if(my $dob = $person->{'dob'}) {
1027
			if($dob =~ /^(\d{3,4})\/\d{2}\/\d{2}$/) {
1028
				$yob = $1;
1029
				$dob =~ tr/\//-/;
1030
			} elsif($dob =~ /^\d{3,4}$/) {
1031
				$yob = $dob;
1032
			}
1033
		}
1034
		next unless(defined($yob));
1035
1036
		my $yod;
1037
		if(my $dod = $person->{'dod'}) {
1038
			if($dod =~ /^(\d{3,4})\/\d{2}\/\d{2}$/) {
1039
				$yod = $1;
1040
				$dod =~ tr/\//-/;
1041
			} elsif($dod =~ /^\d{3,4}$/) {
1042
				$yod = $dod;
1043
			}
1044
		}
1045
1046
		if(!defined($yod)) {
1047
			if($yob < 1920) {
1048
				next;
1049
			}
1050
			$yod = $year;
1051
		}
1052
1053
		my $age = $yod - $yob;
1054
		next if ($age < 20);
1055
		$yob -= $yob % BUCKETYEARS;
1056
		$yod -= $yod % BUCKETYEARS;
1057
		my $bucket = $yob;
1058
1059
		while($bucket <= $yod) {
1060
			if($numberalive{$bucket}) {
1061
				$numberalive{$bucket}++;
1062
			} else {
1063
				$numberalive{$bucket} = 1;
1064
			}
1065
			if($bucket == $yod) {
1066
				if($numberalive{$bucket}) {
1067
					$numberdying{$bucket}++;
1068
				} else {
1069
					$numberdying{$bucket} = 1;
1070
				}
1071
				last;
1072
			}
1073
			$bucket += BUCKETYEARS;
1074
		}
1075
	}
1076
	my $datapoints;
1077
1078
	foreach my $bucket(sort keys(%numberalive)) {
1079
		if($numberalive{$bucket} && $numberdying{$bucket} && $numberalive{$bucket} >= 100) {
1080
			my $percentage = ($numberdying{$bucket} * 100) / $numberalive{$bucket};
1081
			$percentage = floor($percentage);
1082
1083
			$datapoints .= "{ label: \"$bucket\", y: $percentage },\n";
1084
		} elsif(defined($datapoints)) {
1085
			$datapoints .= "{ label: \"$bucket\", y: null },\n";
1086
		}
1087
	}
1088
1089
	return { datapoints => $datapoints };
1090
}
1091
1092
sub _namecloud
1093
{
1094
	my $self = shift;
1095
	my $args = shift;
1096
1097
	my %counts;
1098
1099
	my $names = $args->{'names'};
1100
1101
	my @rc;
1102
1103
	for(my $bucket = 60; $bucket <= 80; $bucket++) {
1104
		my @all = $names->selectall_hash({ entry => $bucket });
1105
1106
		# use Data::Dumper;
1107
		# print Data::Dumper->new([\$all])->Dump();
1108
1109
		my $cloud = HTML::TagCloud->new();
1110
		foreach my $name(@all) {
1111
			my $count = $name->{'count'};
1112
			if($count == 1) {
1113
				$cloud->add($name->{'name'}, "/cgi-bin/page.fcgi?page=people&entry=$name->{people}", 1);
1114
			} else {
1115
				$cloud->add_static($name->{'name'}, $count);
1116
			}
1117
		}
1118
1119
		push @rc, { year => $bucket, data => $cloud->html_and_css(50) };
1120
	}
1121
1122
	return { clouds => \@rc };
1123
}
1124
1125
sub _date_to_datetime
1126
{
1127
	my $self = shift;
1128
	my %params;
1129
1130
	if(ref($_[0]) eq 'HASH') {
1131
		%params = %{$_[0]};
1132
	} elsif(scalar(@_) % 2 == 0) {
1133
		%params = @_;
1134
	} else {
1135
		$params{'date'} = shift;
1136
	}
1137
1138
	return $dfn->parse_datetime(string => $params{'date'});
1139
}
1140
1;