Numeric error propagation: Difference between revisions

Content added Content deleted
m (syntax highlighting fixup automation)
(→‎{{header|Perl}}: eliminated 'uninitialized' warnings, added subroutine signatures, additional tweaks)
Line 1,692:
 
=={{header|Perl}}==
Following code keeps track of covariance between variables. Each variable with error contains its mean value and components of error source from a set of indepententindependent variables. It's more than what the task requires.
<syntaxhighlight lang="perl">use utf8v5.36;
package ErrVar;
use strict;
 
package ErrVar;
# helper function, apply f to pairs (a, b) from listX and listY
sub zip(&$$) {
my ($f, $x, $y) = @_;
my $l = $#$x;
if ($l < $#$y) { $l = $#$y };
 
# helper function, apply function 'f' to pairs (a, b) from listX and listY
my @out;
forsub zip (0$f, ..$x, $ly) {
my @out;
local $a = $x->[$_];
$y = [(0) x @$x] unless @$y; # if not defined
local $b = $y->[$_];
push @out, $f->($x->[$_], $y->[$_]) for 0 .. $#$x;
\@out
}
\@out
}
 
use overload
'""' => \&_str,
'+' => \&_add,
'-' => \&_sub,
'*' => \&_mul,
'/' => \&_div,
'bool' => \&_bool,
'<=>' => \&_ncmp,
'neg' => \&_neg,
'sqrt' => \&_sqrt,
'sqrtlog' => \&_sqrt_log,
'logexp' => \&_log_exp,
'exp**' => \&_exp_pow,
'**' => \&_pow,
;
 
# make a variable with mean value and a list of coefficient to
# variables providing independent errors
sub make ($x, @v) { bless [$x, @v] }
my $x = shift;
bless [$x, [@{+shift}]]
}
 
sub _str { sprintf "%g±%.3g", $_[0][0], sigma($_[0]) }
 
# mean value of the var, or just the input if it's not of this class
sub mean ($x) { ref $x && $x->isa(__PACKAGE__) ? $x->[0] : $x }
sub mean {
my $x = shift;
ref($x) && $x->isa(__PACKAGE__) ? $x->[0] : $x
}
 
# return variance index array
sub vlist ($x) { ref $x && $x->isa(__PACKAGE__) ? $x->[1] : [] }
sub vlist {
my $x = shift;
ref($x) && $x->isa(__PACKAGE__) ? $x->[1] : [];
}
 
sub variance ($x) {
return 0 unless ref($x) and $x->isa(__PACKAGE__);
my $x = shift;
my $s;
return 0 unless ref($x) and $x->isa(__PACKAGE__);
$s += $_ * $_ for @{$x->[1]};
my $s;
$s
$s += $_ * $_ for (@{$x->[1]});
$s
}
 
sub covariance ($x, $y) {
return 0 unless ref($x) && $x->isa(__PACKAGE__);
my ($x, $y) = @_;
return 0 unless ref($xy) && $xy->isa(__PACKAGE__);
my $s;
return 0 unless ref($y) && $y->isa(__PACKAGE__);
zip sub ($a,$b) { $s += $a * $b }, vlist($x), vlist($y);
 
my $s;
zip { $s += $a * $b } vlist($x), vlist($y);
$s
}
 
sub sigma ($v) { sqrt variance(shift) $v }
 
# to determine if a var is probably zero. we use 1σ here
sub _bool ($x, $, $) {
abs(mean $x) > sigma $x
my $x = shift;
return abs(mean($x)) > sigma($x);
}
 
sub _ncmp ($a, $b, $) {
return 0 unless my $x = shift()$a - shift() or return 0$b;
return mean($x) > 0 ? 1 : -1;
}
 
sub _neg ($x, $, $) {
bless [ -mean($x), [map(-$_, @{vlist $x}) ] ];
my $x = shift;
bless [ -mean($x), [map(-$_, @{vlist($x)}) ] ];
}
 
sub _add ($x, $y, $) {
my ($xx0, $yy0) = @_( mean($x), mean($y));
my ($x0xv, $y0yv) = (meanvlist($x), meanvlist($y));
bless [$x0 + $y0, zip sub ($a,$b) {$a + $b}, $xv, $yv]
my ($xv, $yv) = (vlist($x), vlist($y));
bless [$x0 + $y0, zip {$a + $b} $xv, $yv];
}
 
sub _sub ($x, $y, $) {
my ($xx0, $y,y0) = ( mean($swapx), = @_mean($y));
if ($swap) { my ($xxv, $yyv) = (vlist($yx), vlist($xy) });
my ( bless [$x0, - $y0), =zip sub (mean($xa,$b) {$a - $b}, mean($y));xv, $yv]
my ($xv, $yv) = (vlist($x), vlist($y));
bless [$x0 - $y0, zip {$a - $b} $xv, $yv];
}
 
sub _mul ($x, $y, $) {
my ($xx0, $yy0) = @_( mean($x), mean($y));
my ($x0xv, $y0yv) = (meanvlist($x), meanvlist($y));
my ( $xv, $yv) = (vlist[ map($x)y0 * $_, vlist(@$y)xv) ];
$yv = [ map($x0 * $_, @$yv) ];
 
$xv = bless [$x0 * map($y0, *zip sub ($_a,$b) {$a + $b}, @$xv), $yv];
$yv = [ map($x0 * $_, @$yv) ];
 
bless [$x0 * $y0, zip {$a + $b} $xv, $yv];
}
 
sub _div ($x, $y, $) {
my ($xx0, $y,y0) = ( mean($swapx), = @_mean($y));
if ($swap) { my ($xxv, $yyv) = (vlist($yx), vlist($xy) });
$xv = [ map($_/$y0, @$xv) ];
 
my ($x0, $y0)yv = (mean[ map($x)x0 * $_/$y0/$y0, mean(@$y)yv) ];
bless [$x0 / $y0, zip sub ($a,$b) {$a + $b}, $xv, $yv]
my ($xv, $yv) = (vlist($x), vlist($y));
 
$xv = [ map($_/$y0, @$xv) ];
$yv = [ map($x0 * $_/$y0/$y0, @$yv) ];
 
bless [$x0 / $y0, zip {$a + $b} $xv, $yv];
}
 
sub _sqrt ($x, $, $) {
my ($x0, $xv) = ( mean($x), vlist($x) );
my $x = shift;
my $x0 = meansqrt($xx0);
my $xv = vlist[ map($x_ / 2 / $x0, @$xv) ];
bless [$x0, $xv]
$x0 = sqrt($x0);
$xv = [ map($_ / 2 / $x0, @$xv) ];
bless [$x0, $xv]
}
 
sub _pow ($x, $y, $) {
my if ($x, $y,< $swap0) = @_;{
die "Can't take pow of negative number $x" if int($y) != $y or $y & 1;
if ($swap) { ($x, $y) = ($y, $x) }
if ( $x <= 0) {-$x;
}
if (int($y) != $y || ($y & 1)) {
exp($y * log $x)
die "Can't take pow of negative number $x";
}
$x = -$x;
}
exp($y * log $x)
}
 
sub _exp ($x, $, $) {
my ($x0, $xv) = ( exp(mean($x)), vlist($x) );
my $x = shift;
bless [ $x0, [map($x0 * $_, @$xv) ] ]
my $x0 = exp(mean($x));
my $xv = vlist($x);
bless [ $x0, [map($x0 * $_, @$xv) ] ]
}
 
sub _log ($x, $, $) {
my ($x0, $xv) = ( mean($x), vlist($x) );
my $x = shift;
bless [ log($x0), [ map($_ / $x0, @$xv) ] ]
my $x0 = mean($x);
my $xv = vlist($x);
bless [ log($x0), [ map($_ / $x0, @$xv) ] ]
}
 
sub _str { sprintf '%g±%.3g', $_[0][0], sigma($_[0]) }
"If this package were to be in its own file, you need some truth value to end it like this.";
 
package main;
Line 1,873 ⟶ 1,828:
 
my $z1 = sqrt(($x1 - $x2) ** 2 + ($y1 - $y2) ** 2);
printsay "distance: $z1\n\n";
 
# this is not for task requirement
my $a = $x1 + $x2;
my $b = $y1 - 2 * $x2;
printsay "covariance between $a and $b: ", $a->covariance($b), "\n";</syntaxhighlight>output<syntaxhighlight lang="text">distance: 111.803±2.49
{{out}}
 
<pre>distance: 111.803±2.49
covariance between 300±2.46 and -350±4.56: -9.68</syntaxhighlight>
covariance between 300±2.46 and -350±4.56: -9.68</pre>
 
=={{header|Phix}}==
Retrieved from "https://rosettacode.org/wiki/Numeric_error_propagation"