| … | |
… | |
| 160 | my $rvalues = $r->createPointValues($points); |
160 | my $rvalues = $r->createPointValues($points); |
| 161 | # |
161 | # |
| 162 | # Note: $l is bigger if $r can't be evaluated at one of the points |
162 | # Note: $l is bigger if $r can't be evaluated at one of the points |
| 163 | return 1 unless $rvalues; |
163 | return 1 unless $rvalues; |
| 164 | |
164 | |
|
|
165 | my ($i, $cmp); |
|
|
166 | |
| 165 | # |
167 | # |
| 166 | # Handle parameters |
168 | # Handle adaptive parameters: |
|
|
169 | # Get the tolerances, and check each adapted point relative |
|
|
170 | # to the ORIGINAL correct answer. (This will have to be |
|
|
171 | # fixed if we ever do adaptive parameters for non-real formulas) |
| 167 | # |
172 | # |
| 168 | $lvalues = $l->{test_values} |
|
|
| 169 | if $l->AdaptParameters($r,$self->{context}->variables->parameters); |
173 | if ($l->AdaptParameters($r,$self->{context}->variables->parameters)) { |
|
|
174 | my $avalues = $l->{test_adapt}; |
|
|
175 | my $tolerance = $self->getFlag('tolerance',1E-4); |
|
|
176 | my $isRelative = $self->getFlag('tolType','relative') eq 'relative'; |
|
|
177 | my $zeroLevel = $self->getFlag('zeroLevel',1E-14); |
|
|
178 | foreach $i (0..scalar(@{$lvalues})-1) { |
|
|
179 | my $tol = $tolerance; |
|
|
180 | $tol *= abs($lvalues->[$i]) if $isRelative && abs($lvalues->[$i]) > $zeroLevel; |
|
|
181 | return $rvalues->[$i]->value <=> $avalues->[$i]->value |
|
|
182 | unless abs($rvalues->[$i] - $avalues->[$i]) < $tol; |
|
|
183 | } |
|
|
184 | return 0; |
|
|
185 | } |
| 170 | |
186 | |
| 171 | # |
187 | # |
| 172 | # Look through the two lists to see if they are equal. |
188 | # Look through the two lists to see if they are equal. |
| 173 | # If not, return the comparison of the first unequal value |
189 | # If not, return the comparison of the first unequal value |
| 174 | # (not good for < and >, but OK for ==). |
190 | # (not good for < and >, but OK for ==). |
| 175 | # |
191 | # |
| 176 | my ($i, $cmp); |
|
|
| 177 | foreach $i (0..scalar(@{$lvalues})-1) { |
192 | foreach $i (0..scalar(@{$lvalues})-1) { |
| 178 | $cmp = $lvalues->[$i] <=> $rvalues->[$i]; |
193 | $cmp = $lvalues->[$i] <=> $rvalues->[$i]; |
| 179 | return $cmp if $cmp; |
194 | return $cmp if $cmp; |
| 180 | } |
195 | } |
| 181 | return 0; |
196 | return 0; |
| … | |
… | |
| 188 | my $self = shift; |
203 | my $self = shift; |
| 189 | my $points = shift || $self->{test_points} || $self->createRandomPoints; |
204 | my $points = shift || $self->{test_points} || $self->createRandomPoints; |
| 190 | my $showError = shift; |
205 | my $showError = shift; |
| 191 | my @vars = $self->{context}->variables->variables; |
206 | my @vars = $self->{context}->variables->variables; |
| 192 | my @params = $self->{context}->variables->parameters; |
207 | my @params = $self->{context}->variables->parameters; |
| 193 | my @zeros = @{$self->{parameters} || [(0) x scalar(@params)]}; |
208 | my @zeros = (0) x scalar(@params); |
| 194 | my $f = $self->{f}; $f = $self->{f} = $self->perlFunction(undef,[@vars,@params]) unless $f; |
209 | my $f = $self->{f}; $f = $self->{f} = $self->perlFunction(undef,[@vars,@params]) unless $f; |
| 195 | |
210 | |
| 196 | my $values = []; my $v; |
211 | my $values = []; my $v; |
| 197 | foreach my $p (@{$points}) { |
212 | foreach my $p (@{$points}) { |
| 198 | $v = eval {&$f(@{$p},@zeros)}; |
213 | $v = eval {&$f(@{$p},@zeros)}; |
| 199 | if (!defined($v)) { |
214 | if (!defined($v)) { |
| 200 | return unless $showError; |
215 | return unless $showError; |
| 201 | Value::Error("Can't evaluate formula on test point (".join(',',@{$p}).")"); |
216 | Value::Error("Can't evaluate formula on test point (".join(',',@{$p}).")"); |
| 202 | } |
217 | } |
| 203 | push @{$values}, Value::makeValue($v); |
218 | push @{$values}, Value::makeValue($v); |
| 204 | } |
219 | } |
| 205 | |
|
|
| 206 | $self->{test_points} = $points; |
220 | $self->{test_points} = $points; |
| 207 | $self->{test_values} = $values; |
221 | $self->{test_values} = $values; |
|
|
222 | } |
|
|
223 | |
|
|
224 | # |
|
|
225 | # Create the adapted value list for the test points |
|
|
226 | # |
|
|
227 | sub createAdaptedValues { |
|
|
228 | my $self = shift; |
|
|
229 | my $points = shift || $self->{test_points} || $self->createRandomPoints; |
|
|
230 | my $showError = shift; |
|
|
231 | my @vars = $self->{context}->variables->variables; |
|
|
232 | my @params = $self->{context}->variables->parameters; |
|
|
233 | my $f = $self->{f}; $f = $self->{f} = $self->perlFunction(undef,[@vars,@params]) unless $f; |
|
|
234 | |
|
|
235 | my $values = []; my $v; |
|
|
236 | my @adapt = @{$self->{parameters}}; |
|
|
237 | foreach my $p (@{$points}) { |
|
|
238 | $v = eval {&$f(@{$p},@adapt)}; |
|
|
239 | if (!defined($v)) { |
|
|
240 | return unless $showError; |
|
|
241 | Value::Error("Can't evaluate formula on test point (".join(',',@{$p}).") ". |
|
|
242 | "with parameters (".join(',',@adapt).")"); |
|
|
243 | } |
|
|
244 | push @{$values}, Value::makeValue($v); |
|
|
245 | } |
|
|
246 | $self->{test_adapt} = $values; |
| 208 | } |
247 | } |
| 209 | |
248 | |
| 210 | # |
249 | # |
| 211 | # Create a list of random points, making sure that the function |
250 | # Create a list of random points, making sure that the function |
| 212 | # is defined at the given points. Error if we can't find enough. |
251 | # is defined at the given points. Error if we can't find enough. |
| … | |
… | |
| 359 | $l->Error("Adaptive constant is too large: $params[$i] = $row->[0]"); |
398 | $l->Error("Adaptive constant is too large: $params[$i] = $row->[0]"); |
| 360 | } |
399 | } |
| 361 | push @a, $row->[0]; $i++; |
400 | push @a, $row->[0]; $i++; |
| 362 | } |
401 | } |
| 363 | $l->{parameters} = [@a]; |
402 | $l->{parameters} = [@a]; |
| 364 | $l->createPointValues; |
403 | $l->createAdaptedValues; |
| 365 | return 1; |
404 | return 1; |
| 366 | } |
405 | } |
| 367 | } |
406 | } |
| 368 | $l->Error("Can't solve for adaptive parameters"); |
407 | $l->Error("Can't solve for adaptive parameters"); |
| 369 | } |
408 | } |
Parent Directory
| 
Revision Log
| 
Patch