PageRenderTime 63ms CodeModel.GetById 22ms RepoModel.GetById 0ms app.codeStats 0ms

/lib/Demeter/Fit.pm

https://bitbucket.org/bruceravel/demeter
Perl | 2227 lines | 1632 code | 368 blank | 227 comment | 205 complexity | ea02d8883a2bcbabe0513f53c3b12f09 MD5 | raw file
Possible License(s): LGPL-2.0, GPL-2.0
  1. package Demeter::Fit;
  2. =for Copyright
  3. .
  4. Copyright (c) 2006-2017 Bruce Ravel (http://bruceravel.github.io/home).
  5. All rights reserved.
  6. .
  7. This file is free software; you can redistribute it and/or
  8. modify it under the same terms as Perl itself. See The Perl
  9. Artistic License.
  10. .
  11. This program is distributed in the hope that it will be useful,
  12. but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14. =cut
  15. #use diagnostics;
  16. use autodie qw( open close );
  17. use File::Copy;
  18. use File::Spec;
  19. use Moose;
  20. extends 'Demeter';
  21. use MooseX::Aliases;
  22. with 'Demeter::Fit::Happiness';
  23. #with 'Demeter::Fit::Horae';
  24. with 'Demeter::Fit::Sanity';
  25. if ($Demeter::mode->ui eq 'screen') {
  26. with 'Demeter::UI::Screen::Interview';
  27. with 'Demeter::UI::Screen::Progress';
  28. };
  29. use Demeter::NumTypes qw( NonNeg Natural NaturalC );
  30. use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
  31. local $Archive::Zip::UNICODE = 1;
  32. use Carp;
  33. use Cwd;
  34. use File::Basename;
  35. use File::Copy;
  36. use File::Path;
  37. use File::Spec;
  38. use List::Util qw(max);
  39. use List::MoreUtils qw(any none zip uniq minmax);
  40. use Regexp::Assemble;
  41. use Demeter::Constants qw($NUMBER $NULLFILE $STATS);
  42. use Text::Wrap;
  43. use YAML::Tiny;
  44. use Text::Wrap;
  45. $Text::Wrap::columns = 65;
  46. ## -------- properties
  47. has 'description' => (is => 'rw', isa => 'Str', default => q{});
  48. has 'fom' => (is => 'rw', isa => 'LaxNum', default => 0);
  49. has 'fitenvironment' => (is => 'rw', isa => 'Str', default => sub{ shift->environment });
  50. has 'interface' => (is => 'rw', isa => 'Str', default => 'Demeter-based perl script'); # should be sensitive to :ui "pragma"
  51. has 'started' => (is => 'rw', isa => 'Str', default => q{}); # should be a Date/Time object
  52. has 'time_of_fit' => (is => 'rw', isa => 'Str', default => q{}); # should be a Date/Time object
  53. has 'prepared_by' => (is => 'rw', isa => 'Str', default => sub{ shift->who });
  54. has 'contact' => (is => 'rw', isa => 'Str', default => q{});
  55. has 'fitted' => (is => 'rw', isa => 'Bool', default => 0);
  56. has 'update_gds' => (is => 'rw', isa => 'Bool', default => 1);
  57. has 'number' => (is => 'rw', isa => 'LaxNum', default => 0);
  58. ## -------- serialization/deserialization
  59. has 'project' => (is => 'rw', isa => 'Str', default => q{},
  60. trigger => sub{my ($self, $new) = @_; $self->deserialize(file=>$new) if $new} );
  61. has 'folder' => (is => 'rw', isa => 'Str', default => q{});
  62. has 'grabbed' => (is => 'rw', isa => 'Bool', default => 0);
  63. has 'thawed' => (is => 'rw', isa => 'Bool', default => 0);
  64. has 'logcache' => (is => 'rw', isa => 'Str', default => q{});
  65. has 'keep' => (is => 'rw', isa => 'Bool', default => 1);
  66. ## -------- mechanics of the fit
  67. has 'cormin' => (is => 'rw', isa => NonNeg, default => sub{ shift->co->default("fit", "cormin") || 0.4});
  68. has 'header' => (is => 'rw', isa => 'Str', default => q{});
  69. has 'footer' => (is => 'rw', isa => 'Str', default => q{});
  70. has 'restraints' => (is => 'rw', isa => 'Str', default => q{});
  71. has 'ndata' => (is => 'rw', isa => Natural, default => 0);
  72. has 'indeces' => (is => 'rw', isa => 'Str', default => q{});
  73. has 'location' => (is => 'rw', isa => 'Str', default => q{});
  74. has 'fit_performed' => (is => 'rw', isa => 'Bool', default => 0);
  75. has 'ignore_errors' => (is => 'rw', isa => 'Bool', default => 0);
  76. has 'stop' => (is => 'rw', isa => 'Bool', default => 0);
  77. has 'troubletext' => (is => 'rw', isa => 'Str', default => q{});
  78. ## -------- flags for skipping certain sanity checks
  79. has 'ignore_nidp' => (is => 'rw', isa => 'Bool', default => 0);
  80. has 'ignore_rbkg' => (is => 'rw', isa => 'Bool', default => 0);
  81. has 'ignore_rmax' => (is => 'rw', isa => 'Bool', default => 0);
  82. has 'ignore_datacollision' => (is => 'rw', isa => 'Bool', default => 0);
  83. ## -------- array attributes
  84. has 'gds' => (
  85. traits => ['Array'],
  86. is => 'rw',
  87. isa => 'ArrayRef',
  88. default => sub { [] },
  89. handles => {
  90. 'push_gds' => 'push',
  91. 'pop_gds' => 'pop',
  92. 'shift_gds' => 'shift',
  93. 'unshift_gds' => 'unshift',
  94. 'clear_gds' => 'clear',
  95. },
  96. trigger => sub{my ($self) = @_; $self->update_gds(1)},
  97. );
  98. has 'data' => (
  99. traits => ['Array'],
  100. is => 'rw',
  101. isa => 'ArrayRef',
  102. default => sub { [] },
  103. handles => {
  104. 'push_data' => 'push',
  105. 'pop_data' => 'pop',
  106. 'shift_data' => 'shift',
  107. 'unshift_data' => 'unshift',
  108. 'clear_data' => 'clear',
  109. }
  110. );
  111. has 'datagroups' => (is => 'rw', isa => 'ArrayRef', default => sub{[]});
  112. has 'paths' => (
  113. traits => ['Array'],
  114. is => 'rw',
  115. isa => 'ArrayRef',
  116. default => sub { [] },
  117. handles => {
  118. 'push_paths' => 'push',
  119. 'pop_paths' => 'pop',
  120. 'shift_paths' => 'shift',
  121. 'unshift_paths' => 'unshift',
  122. 'clear_paths' => 'clear',
  123. }
  124. );
  125. has 'vpaths' => (
  126. traits => ['Array'],
  127. is => 'rw',
  128. isa => 'ArrayRef',
  129. default => sub { [] },
  130. handles => {
  131. 'push_vpaths' => 'push',
  132. 'pop_vpaths' => 'pop',
  133. 'shift_vpaths' => 'shift',
  134. 'unshift_vpaths' => 'unshift',
  135. 'clear_vpaths' => 'clear',
  136. }
  137. );
  138. ## -------- statistics
  139. has 'happiness' => (is => 'rw', isa => NonNeg, default => 0);
  140. has 'happiness_summary' => (is => 'rw', isa => 'Str', default => q{});
  141. has 'n_idp' => (is => 'rw', isa => NonNeg, default => 0);
  142. has 'n_varys' => (is => 'rw', isa => NaturalC, default => 0, coerce => 1);
  143. has 'data_total' => (is => 'rw', isa => NaturalC, default => 0, coerce => 1);
  144. has 'epsilon_k' => (is => 'rw', isa => NonNeg, default => 0);
  145. has 'epsilon_r' => (is => 'rw', isa => NonNeg, default => 0);
  146. has 'r_factor' => (is => 'rw', isa => NonNeg, default => 0);
  147. has 'chi_square' => (is => 'rw', isa => NonNeg, default => 0);
  148. has 'chi_reduced' => (is => 'rw', isa => NonNeg, default => 0);
  149. ## deprecated and unused...
  150. has 'fancyline' => (is => 'rw', isa => 'Str', default => q{});
  151. has 'correlations' => (
  152. traits => ['Hash'],
  153. is => 'rw',
  154. isa => 'HashRef[HashRef]',
  155. default => sub { {} },
  156. handles => {
  157. 'exists_in_correlations' => 'exists',
  158. 'keys_in_correlations' => 'keys',
  159. 'get_correlations' => 'get',
  160. 'set_correlations' => 'set',
  161. }
  162. );
  163. has 'parameters' => (
  164. traits => ['Array'],
  165. is => 'rw',
  166. isa => 'ArrayRef',
  167. default => sub { [] },
  168. handles => {
  169. 'push_parameters' => 'push',
  170. 'pop_parameters' => 'pop',
  171. 'clear_parameters' => 'clear',
  172. }
  173. );
  174. has 'pathresults' => (
  175. traits => ['Array'],
  176. is => 'rw',
  177. isa => 'ArrayRef',
  178. default => sub { [] },
  179. handles => {
  180. 'push_pathresults' => 'push',
  181. 'pop_pathresults' => 'pop',
  182. 'clear_pathresults' => 'clear',
  183. }
  184. );
  185. sub BUILD {
  186. my ($self, @params) = @_;
  187. $self->mo->push_Fit($self);
  188. $self->number($self->mo->currentfit);
  189. };
  190. # sub set_all {
  191. # my ($self, $which, $rhash) = @_;
  192. # return 0 if ($which !~ m{\A(?:data|gds|paths)\z}i);
  193. # return 0 if (ref($rhash) ne 'HASH');
  194. # my @list = @{ $component_of{ident $self}{$which} };
  195. # foreach my $obj (@list) {
  196. # $obj -> set($rhash);
  197. # };
  198. # return $self;
  199. # };
  200. sub DEMOLISH {
  201. my ($self) = @_;
  202. $self->alldone;
  203. };
  204. override 'alldone' => sub {
  205. my ($self) = @_;
  206. $self->remove;
  207. rmtree $self->folder if (-d $self->folder);
  208. };
  209. override all => sub {
  210. my ($self) = @_;
  211. my %all = $self->SUPER::all;
  212. delete $all{gds};
  213. delete $all{data};
  214. delete $all{paths};
  215. delete $all{vpaths};
  216. delete $all{logcache};
  217. return %all;
  218. };
  219. override Clone => sub {
  220. my ($self, @arguments) = @_;
  221. my $new = ref($self) -> new();
  222. my %hash = $self->SUPER::all;
  223. delete $hash{group};
  224. $new -> set(%hash);
  225. $new -> set(@arguments);
  226. ## the cloned object needs its own group name
  227. #$new->group($self->_get_group());
  228. return $new;
  229. };
  230. sub rm {
  231. my ($self) = @_;
  232. #print "removing ", $self->location, $/;
  233. rmtree($self->location);
  234. };
  235. ## ------------------------------------------------------------
  236. ## sanity checks see Demeter::Fit::Sanity
  237. sub _verify_fit {
  238. my ($self) = @_;
  239. my $trouble_found = 0;
  240. my @gds = @{ $self->gds };
  241. $self->add_trouble("gds"), ++$trouble_found if ($#gds == -1);
  242. my @data = @{ $self->data };
  243. $self->add_trouble("data"), ++$trouble_found if ($#data == -1);
  244. my @paths = @{ $self->paths };
  245. $self->add_trouble("paths"), ++$trouble_found if ($#paths == -1);
  246. ## all these tests live in Demeter::Fit::Sanity
  247. ## 1. check that all data and feffNNNN.dat files exist
  248. $trouble_found += $self->S_data_files_exist;
  249. $trouble_found += $self->S_feff_files_exist;
  250. ## 2. Check that the Path sp attributes are set sensibly
  251. $trouble_found += $self->S_sp_exist;
  252. ## 3. check that all guesses are used in defs and pathparams
  253. $trouble_found += $self->S_defined_not_used;
  254. ## 4. check that defs and path paramers do not use undefined GDS parameters
  255. $trouble_found += $self->S_used_not_defined;
  256. ## 5. check that ++ -- // *** do not appear in math expression
  257. $trouble_found += $self->S_binary_ops;
  258. ## 6. check that all function() names are valid in math expressions
  259. $trouble_found += $self->S_function_names;
  260. ## 7. check that all data have unique group names and tags
  261. ## 8. check that all paths have unique group names
  262. $trouble_found += $self->S_unique_group_names;
  263. ## 9. check that all GDS have unique names
  264. $trouble_found += $self->S_gds_unique_names;
  265. ## 10. check that parens match
  266. $trouble_found += $self->S_parens_not_match;
  267. ## 11. check that data parameters are sensible
  268. $trouble_found += $self->S_data_parameters;
  269. ## 12. check number of guesses against Nidp
  270. $trouble_found += $self->S_nidp unless $self->ignore_nidp;
  271. ## 13. verify that Rmin is >= Rbkg for data imported as mu(E)
  272. $trouble_found += $self->S_rmin_rbkg unless $self->ignore_rbkg;
  273. ## 14. verify that Reffs of all paths are within some margin of rmax
  274. $trouble_found += $self->S_reff_rmax unless $self->ignore_rmax;
  275. ## 15. check that Ifeffit's hard wired limits are not exceeded
  276. $trouble_found += $self->S_exceed_ifeffit_limits;
  277. ## 16. check that parameters do not have program variable names
  278. $trouble_found += $self->S_program_var_names;
  279. ## 17.1. check that parameters do not have unallowed characters in their names
  280. $trouble_found += $self->S_bad_character;
  281. ## 18. check that all Path objects have either a ScatteringPath or a folder/file defined
  282. $trouble_found += $self->S_path_calculation_exists;
  283. ## 19. check that there are no unresolved merge parameters
  284. $trouble_found += $self->S_notice_merge;
  285. ## 20. check that no more than one path is flagged as the default path
  286. $trouble_found += $self->S_default_path;
  287. ## 21. check that GDS math expressions do not have loops or cycles
  288. $trouble_found += $self->S_cycle_loop;
  289. ## 22. check for obvious cases of a data set used more than once
  290. $trouble_found += $self->S_data_collision unless $self->ignore_datacollision;
  291. ## 23. check that each data set used in the fit has one or more paths assigned to it
  292. $trouble_found += $self->S_data_paths;
  293. return $trouble_found;
  294. };
  295. ## ------------------------------------------------------------
  296. ## fit and ff2chi
  297. sub pre_fit {
  298. my ($self) = @_;
  299. ## reset use attribute (in case this fit involved local parameters)
  300. ## and clear all trouble attributes
  301. foreach my $gds (@{ $self->gds }) {
  302. $gds -> Use(1);
  303. $gds -> trouble(q{});
  304. };
  305. foreach my $d (@{ $self->data }) {
  306. $d -> fitting(0);
  307. $d -> trouble(q{});
  308. };
  309. foreach my $p (@{ $self->paths }) {
  310. $p -> _update('path') if (ref($p) =~ m{FSPath});
  311. $p -> trouble(q{});
  312. #print $/;
  313. #print $p->s02, $/;
  314. #print $p->e0, $/;
  315. #print $p->delr, $/;
  316. #print $p->sigma2, $/;
  317. };
  318. $self -> trouble(q{});
  319. $self -> troubletext(q{});
  320. return $self->template("fit", "prep_fit");
  321. };
  322. sub fit {
  323. my ($self) = @_;
  324. $self->stop(0);
  325. local $SIG{ALRM} = sub { 1; } if not $SIG{ALRM};
  326. $self->start_spinner("Demeter is performing a fit") if ($self->mo->ui eq 'screen');
  327. my $prefit = $self->pre_fit;
  328. $self->number($self->mo->currentfit);
  329. my $trouble_found = $self->_verify_fit;
  330. if ($trouble_found) {
  331. $self->stop(1);
  332. my $text = $self->trouble_report;
  333. carp($text) if ($self->mo->ui ne 'Wx');
  334. $self->troubletext($text);
  335. if (not $self->ignore_errors) {
  336. if ($self->mo->ui eq 'Wx') {
  337. return "This fit has unrecoverable errors";
  338. } else {
  339. croak("This fit has unrecoverable errors");
  340. };
  341. };
  342. };
  343. return "Tilt!" if $self->stop;
  344. $self->dispose($prefit);
  345. foreach my $gds (@{ $self->gds }) {
  346. $self->dispense("fit", "erase_gds", {items=>$gds->name});
  347. };
  348. $self->mo->fit($self);
  349. $self->mo->pathindex(1);
  350. foreach my $p (@{ $self->paths }) {
  351. $self->dispense('fit', 'path_index') if ($p->default_path);
  352. ##$self->dispose("set path_index = " . $p->Index) if ($p->default_path);
  353. };
  354. my $command = q{};
  355. foreach my $type (qw(guess lguess set def restrain)) {
  356. $command .= $self->_gds_commands($type);
  357. };
  358. $self->update_gds(0);
  359. ## get a list of all data sets included in the fit
  360. my @datasets = @{ $self->data };
  361. my @useddata = grep {$_->fit_include && $_} @datasets;
  362. my $ndata = $#useddata+1;
  363. my $ipath = 0;
  364. my $count = 0;
  365. my $str = q{};
  366. $self->name("fit to " . join(", ", map {$_->name} @useddata)) if not $self->name;
  367. $self->description("fit to " . join(", ", map {$_->name} @useddata)) if not $self->description;
  368. ## munge parameters and path parameters to deal with lguess
  369. $command .= $self->_local_parameters;
  370. my $restraints_string = q{};
  371. foreach my $gds (@{ $self->gds }) {
  372. if (($gds->gds eq 'restrain') and ($gds->Use)) {
  373. #$restraints_string .= "restraint=%s, ", $gds->name;
  374. my $this = $gds->template("fit", "restraint");
  375. chomp($this);
  376. $restraints_string .= $this;
  377. };
  378. };
  379. if ($restraints_string) {
  380. $restraints_string = substr($restraints_string, 0, -2);
  381. $restraints_string = wrap("", " ", $restraints_string);
  382. };
  383. $self -> restraints($restraints_string);
  384. $self -> ndata($ndata);
  385. foreach my $data (@datasets) {
  386. next if not $data->fit_include;
  387. ++$count;
  388. $data -> set(fitting=>1, fit_data=>$count, fit_group=>$self->group);
  389. ## read the data
  390. $data -> _update('fft');
  391. $command .= "\n";
  392. ## define all the paths for this data set
  393. ##
  394. ## ifeffit needs a list of path indeces
  395. ## larch needs a list of path group names, larch uses the misnamed indeces attribute to carry this list
  396. my $group = $data->group;
  397. my @indexstring = ();
  398. my $iii=1;
  399. foreach my $p (@{ $self->paths }) {
  400. next if not defined($p);
  401. next if ($p->data ne $data);
  402. next if not $p->include;
  403. $p->_update_from_ScatteringPath if $p->sp;
  404. ++$ipath;
  405. my $i = $p->mo->pathindex;
  406. $p->Index($i);
  407. $p->mo->pathindex(++$i);
  408. my $lab = $p->name;
  409. ($lab = "path $ipath") if ($lab =~ m{\A(?:\s*|path\s+\d+)\z});
  410. $p->set(name=>$lab);
  411. $p->rewrite_cv;
  412. my $this_command = $p->_path_command(0);
  413. $this_command =~ s{(?<!sigma2_)(debye|eins)\(}{sigma2_$1\(}g if (Demeter->is_larch);
  414. $this_command =~ s{sigma2_(debye|eins)\(}{$1\(}g if (Demeter->is_ifeffit);
  415. $command .= $this_command;
  416. if (Demeter->is_ifeffit) {
  417. push @indexstring, $p->Index;
  418. } elsif (Demeter->is_larch) {
  419. push @indexstring, $p->group;
  420. };
  421. };
  422. $command .= "\n";
  423. $command .= $data->template("fit", "next") if ($count > 1);
  424. if (Demeter->is_ifeffit) {
  425. $self -> indeces(_normalize_paths(\@indexstring));
  426. } elsif (Demeter->is_larch) {
  427. $self -> indeces(join(',', @indexstring));
  428. };
  429. if ($data->fit_data lt $self->ndata) {
  430. $command .= $data->template("fit", "fit");
  431. } else {
  432. my @mdsgroups = map {$_->group} @datasets;
  433. $command .= $data->template("fit", "endfit", {MDS=>\@mdsgroups});
  434. };
  435. $self -> restraints(q{}) if ($count == 1);
  436. $data -> fitsum('fit');
  437. };
  438. ## write out afters
  439. $command .= $self->_gds_commands('after');
  440. ## make residual and background arrays
  441. foreach my $data (@useddata) {
  442. $command .= $data->template("fit", "residual");
  443. if ($data->fit_do_bkg) {
  444. $command .= $data->template("fit", "background");
  445. };
  446. };
  447. #my @xxx = Ifeffit::get_array('lmzpb_fit.k');
  448. #Demeter->pjoin(3, minmax(@xxx));
  449. #print $command, $/;
  450. $self->dispose($command);
  451. #@xxx = Ifeffit::get_array('lmzpb_fit.k');
  452. #Demeter->pjoin(3.1, minmax(@xxx));
  453. $self->evaluate;
  454. ## set happiness statistics
  455. my @joy = $self->get_happiness;
  456. $self->happiness( $joy[0] || 0 );
  457. $self->happiness_summary( $joy[1] || q{} );
  458. foreach my $g (@ {$self->gds}) {
  459. $g->autoannotate;
  460. };
  461. $self->fitted(1);
  462. $self->mo->fit(q{});
  463. $self->mo->increment_fit;
  464. ## prep data for plotting
  465. foreach my $data (@useddata) {
  466. $data->update_fft(1);
  467. #$data->fitting(0);
  468. #$data->fit_group(q{});
  469. };
  470. $self->stop_spinner if ($self->mo->ui eq 'screen');
  471. #$self->ifeffit_heap;
  472. return $self;
  473. };
  474. alias feffit => 'fit';
  475. sub sum {
  476. my ($self, $data) = @_;
  477. $data ||= $self->data->[0];
  478. my $sum = Demeter::VPath->new(name=>$self->name . ' -- sum');
  479. foreach my $p (@{ $self->paths }) {
  480. next if ($data ne $p->data);
  481. $sum -> include($p);
  482. };
  483. if ($self->update_gds) {
  484. my $command = q{};
  485. foreach my $type (qw(guess lguess set def)) {
  486. $command .= $self->_gds_commands($type);
  487. };
  488. $self->dispose($command);
  489. $self->update_gds(0);
  490. };
  491. return $sum;
  492. };
  493. sub trouble_report {
  494. my ($fit) = @_;
  495. my $text = q{};
  496. $Text::Wrap::columns = 60;
  497. foreach my $obj ($fit, @{ $fit->data }, @{ $fit->gds }, @{ $fit->paths }) {
  498. next if not $obj->trouble;
  499. my $which = ref($obj);
  500. $which =~ s{Demeter::}{};
  501. foreach my $t (split(/\|/, $obj->trouble)) {
  502. my $pathfile = q{};
  503. if ($which =~ m{Path}) {
  504. #$pathfile = ($obj->sp) ? $obj->sp->intrpline : File::Spec->catfile($obj->folder, $obj->file);
  505. #$pathfile = '(' . $pathfile . ')';
  506. $pathfile = "in data set '".$obj->data->name."'";
  507. };
  508. $text .= sprintf("%s: '%s' %s\n%s\n\n", uc($which), $obj->name, $pathfile,
  509. wrap(" ", " ", $obj->translate_trouble($t)));
  510. ##$text .= sprintf("%s: %s\t(%s)\n%s\n\n", $which, $obj->name, $t, wrap(" ", " ", $obj->translate_trouble($t)));
  511. };
  512. };
  513. return $text;
  514. };
  515. sub _gds_commands {
  516. my ($self, $type) = @_;
  517. my $string = q{};
  518. foreach my $gds (@{ $self->gds }) {
  519. next unless ($gds->gds eq lc($type));
  520. next if (not $gds->Use);
  521. $string .= $gds -> write_gds;
  522. $gds->initial($gds->mathexp);
  523. };
  524. $string = "\n" . $self->hashes . " $type parameters:\n" . $string if $string;
  525. return $string;
  526. };
  527. sub _local_parameters {
  528. my ($self) = @_;
  529. my $string = q{};
  530. my %created = ();
  531. ## list of lguesses
  532. my @local_list = grep {$_->gds eq 'lguess'} (@{ $self->gds });
  533. ## regex that matches all the lguesses
  534. my $local_regex = join("|", map {$_->name} @local_list);
  535. return q{} if (not $local_regex);
  536. ## need to fetch a complete list of lguess and the def, after,
  537. ## restrain that depend upon lguess by digging into the math
  538. ## expression dependencies
  539. my $continue = 1;
  540. while ($continue) {
  541. my $count = 0;
  542. my @llist = ();
  543. foreach my $gds (@{ $self->gds }) {
  544. next if ($gds->name =~ m{\b($local_regex)\b}i);
  545. next if ($gds->gds =~ m{(?:skip|merge)});
  546. if (($gds->mathexp =~ m{\b($local_regex)\b}i) and
  547. (none {$gds->name eq $_->name} @local_list)) {
  548. push @llist, $gds;
  549. ++$count;
  550. };
  551. };
  552. push @local_list, @llist;
  553. $local_regex = join("|", map {$_->name} @local_list);
  554. $continue = $count;
  555. };
  556. ## need to unguess any locally dependent guesses
  557. my $setguess_header_written = 0;
  558. foreach my $p (@local_list) {
  559. next if ($p->gds ne 'guess');
  560. if (not $setguess_header_written) {
  561. $string .= "\n" . $self->hashes . " unguessing locally dependent guess parameters:\n";
  562. $setguess_header_written = 1;
  563. };
  564. $p->Use(0); # so it doesn't get reported in the log file
  565. my $this = $p->name;
  566. $string .= "set $this = $this\n";
  567. };
  568. ## need to make a mapping of param names back to their objects
  569. my @keys = map {$_->name} @local_list;
  570. my %type = zip(@keys, @local_list);
  571. ## loop through all the data to find and rewrite math expressions
  572. ## that depend on lguesses
  573. foreach my $data (@{$self->data}) {
  574. my $tag = $data->cv || $data->tag;
  575. $tag =~ s{\.}{_}g;
  576. $string .= "\n" . $self->hashes . " local guess and def parameters for " . $data->name . ":\n";
  577. foreach my $p (@{ $self->paths }) {
  578. next if not defined($p);
  579. next if ($p->data->group ne $data->group);
  580. next if not $p->include;
  581. foreach my $pp (qw(e0 ei sigma2 s02 delr third fourth dphase)) {
  582. my $me = $p->$pp;
  583. if ($me =~ m{\b($local_regex)\b}i) {
  584. my $global = $1;
  585. my $local = join("_", $global, $tag);
  586. ## correct this path parameter's math expression
  587. $me =~ s/\b$global\b/$local/g;
  588. $p->$pp($me);
  589. ## define a local guess and rewrite local guesses if not
  590. ## already defined
  591. if (not $created{$local}) {
  592. my ($this_me, $this_type) = ($global, 'guess');
  593. if ($type{$global}->gds eq 'def') {
  594. $this_type = "def";
  595. ($this_me = $type{$global}->mathexp) =~ s{\b($local_regex)\b}{$1_$tag}g;
  596. };
  597. my $new_gds = Demeter::GDS->new(gds => $this_type,
  598. name => $local,
  599. mathexp => $this_me);
  600. $self->push_gds($new_gds);
  601. $string .= $new_gds -> write_gds;
  602. ++$created{$local};
  603. };
  604. };
  605. };
  606. };
  607. ## rewrite remaining defs and all afters
  608. foreach my $ldef (@local_list) {
  609. next if ($ldef->gds !~ m{(?:after|def)});
  610. my $global = $ldef->name;
  611. my $local = join("_", $global, $tag);
  612. my $me = $ldef->mathexp;
  613. $me =~ s{\b($local_regex)\b}{$1_$tag}g;
  614. next if ($created{$local});
  615. my $new_gds = Demeter::GDS->new(gds => $ldef->gds,
  616. name => $local,
  617. mathexp => $me);
  618. $self->push_gds($new_gds);
  619. $string .= $new_gds -> write_gds if ($ldef->gds eq 'def');
  620. $ldef->Use(0) if ($ldef->gds eq 'after');
  621. ++$created{$local};
  622. };
  623. ## next rewrite restraints
  624. my $restraint_header_written = 0;
  625. foreach my $lres (@local_list) {
  626. next if ($lres->gds ne 'restrain');
  627. if (not $restraint_header_written) {
  628. $string .= "\n" . $self->hashes . " local restraints " . $data->name . ":\n";
  629. $restraint_header_written = 1;
  630. };
  631. my $global = $lres->name;
  632. my $local = join("_", $global, $tag);
  633. my $me = $lres->mathexp;
  634. $me =~ s{\b($local_regex)\b}{$1_$tag}g;
  635. next if ($created{$local});
  636. my $new_gds = Demeter::GDS->new(gds => 'restrain',
  637. name => $local,
  638. mathexp => $me);
  639. $self->push_gds($new_gds);
  640. $lres -> Use(0);
  641. $string .= $new_gds -> write_gds;
  642. ++$created{$local};
  643. };
  644. };
  645. ## finally set expandsto attribute of each lguess
  646. foreach my $l (@local_list) {
  647. my $this = $l->name;
  648. my @these = ();
  649. foreach my $c (sort keys %created) {
  650. push(@these, $c) if ($c =~ m{\A$this});
  651. };
  652. $l -> expandsto(join(", ", @these));
  653. };
  654. return $string;
  655. };
  656. # swiped from the old Ifeffit::IO:
  657. # change (3,1,14,5,15,2,13,7,8,6,12) to "1-3,5-8,12-15"
  658. sub _normalize_paths {
  659. my @tmplist; # expand 'X-Y'
  660. map { push @tmplist, ($_ =~ /(\d+)-(\d+)/) ? $1 .. $2 : $_ } @{$_[0]};
  661. my @list = grep /\d+/, @tmplist; # weed out non-integers
  662. @list = sort {$a<=>$b} @list; # sort 'em
  663. my $this = shift(@list);
  664. my $string = $this;
  665. my ($prev, $concat) = ('', '');
  666. while (@list) {
  667. $prev = $this;
  668. $this = shift(@list);
  669. if ($this == $prev+1) {
  670. $concat = "-";
  671. } else {
  672. $concat = ",";
  673. $string .= join("", "-", $prev, $concat, $this);
  674. };
  675. $prev = $this;
  676. };
  677. ($concat eq "-") and $string .= $concat . $this;
  678. $string =~ s{(\d+)-(\1)\b}{$1}g;
  679. return $string || q{};
  680. };
  681. sub evaluate {
  682. my ($self) = @_;
  683. ## retrieve bestfit and errors for gds params, handle annotation
  684. foreach my $gds (@{ $self->gds }) {
  685. $gds->evaluate;
  686. };
  687. ## evaluate all path parameter math expressions
  688. foreach my $path (@{ $self->paths }) {
  689. next if not defined($path);
  690. $path->fetch;
  691. $path->update_path(1);
  692. };
  693. ## get fit and data set statistics (store in fit and data objects respectively)
  694. $self->fetch_statistics;
  695. ## get_parameter values for this fit
  696. $self->fetch_parameters;
  697. ## get correlations
  698. $self->fetch_correlations;
  699. ## get path parameters
  700. $self->fetch_pathresults;
  701. ## set properties
  702. $self->set(time_of_fit=>$self->now, fit_performed=>1);
  703. return $self;
  704. };
  705. my @keys = qw(name description fom time_of_fit fitenvironment interface prepared_by contact);
  706. my @vals = ('Name', 'Description', 'Figure of merit', 'Time of fit', 'Environment', 'Interface', 'Prepared by', 'Contact');
  707. my %properties = zip(@keys, @vals);
  708. sub properties_header {
  709. my ($self, $is_summary) = @_;
  710. my $string = "\n";
  711. foreach my $k (@keys) {
  712. next if ($is_summary and ($k !~ m{name|description|fom}));
  713. if ($k eq 'description') {
  714. my @lines = ($self->$k) ? split($/, $self->$k) : (q{});
  715. $string .= sprintf " %-15s : %s\n", $properties{$k}, shift @lines;
  716. $string .= (sprintf " %-15s %s\n", ' ...', $_) foreach @lines;
  717. } else {
  718. $string .= sprintf " %-15s : %s\n", $properties{$k}, $self->$k;
  719. };
  720. };
  721. return $string;
  722. };
  723. sub summary {
  724. my ($self) = @_;
  725. my $text = q{};
  726. $text .= $self->template("report", "properties_summary");
  727. $text .= $self->template("report", "statistics"); #statistics_report;
  728. $text .= $self->gds_report;
  729. $text .= $self->template("report", "fancyline");
  730. return $text;
  731. };
  732. sub logfile {
  733. my ($self, $fname, $header, $footer) = @_;
  734. $header ||= $self->get('header') || q{};
  735. $footer ||= $self->get('footer') || q{};
  736. open my $LOG, ">$fname";
  737. print $LOG $self->logtext($header, $footer);
  738. close $LOG;
  739. return $self;
  740. };
  741. sub logtext {
  742. my ($self, $header, $footer) = @_;
  743. $header ||= q{};
  744. $footer ||= q{};
  745. $self -> set(header=>$header, footer=>$footer);
  746. ($header .= "\n") if ($header !~ m{\n\z});
  747. #return $self->logcache if $self->logcache;
  748. my $text = q{};
  749. return $text if (not @{ $self->paths });
  750. $text .= $header;
  751. $text .= $self->template("report", "properties"); #properties_header;
  752. $text .= $self->template("report", "fancyline");
  753. $text .= $self->template("report", "statistics"); #statistics_report;
  754. $text .= $self->template("report", "happiness"); #happiness_report;
  755. $text .= $self->gds_report;
  756. $text .= $self->correl_report(); # arg is cormin
  757. foreach my $data (@{ $self->data }) {
  758. next if (not $data->fitting);
  759. $data->rfactor;
  760. if (lc($data->fit_space) eq "r") {
  761. $data->_update("bft");
  762. $data->part_fft("fit") if (lc($data->fitsum) eq 'sum');
  763. };
  764. if (lc($data->fit_space) eq "q") {
  765. $data->_update("bft");
  766. $data->part_fft("fit") if (lc($data->fitsum) eq 'sum');
  767. $data->part_bft("fit") if (lc($data->fitsum) eq 'sum');
  768. };
  769. $text .= $data->fit_parameter_report($#{ $self->data }, $self->fit_performed);
  770. my $length = max( map { length($_->[1]) if ($_->[0] eq $data->group) } @{ $self->pathresults } ) || 10;
  771. $length += 1;
  772. my $pattern = '%-' . $length . 's';
  773. $text .= $self->paths->[0]->row_main_label($length);
  774. foreach my $p (@{ $self->pathresults }) {
  775. next if ($data->group ne $p->[0]);
  776. next if not $p->[11];
  777. $text .= sprintf($pattern, $p->[1]);
  778. $text .= sprintf(" %8.3f %7.3f %9.5f %7.3f %8.5f %8.5f %8.5f\n",
  779. $p->[2], $p->[3], $p->[4], $p->[5], $p->[6], $p->[7], $p->[6]+$p->[7]);
  780. };
  781. $text .= $/;
  782. $text .= $self->paths->[0]->row_second_label($length);
  783. foreach my $p (@{ $self->pathresults }) {
  784. next if ($data->group ne $p->[0]);
  785. next if not $p->[11];
  786. $text .= sprintf($pattern, $p->[1]);
  787. $text .= sprintf(" %9.5f %9.5f %9.5f\n", $p->[8], $p->[9], $p->[10]);
  788. };
  789. };
  790. $text .= $self->template("report", "fancyline");
  791. ($footer .= "\n") if ($footer !~ m{\n\z});
  792. $text .= $footer;
  793. $self->logcache($text);
  794. return $text;
  795. };
  796. sub gds_report {
  797. my ($self) = @_;
  798. my $text = q{};
  799. foreach my $type (qw(guess lguess set def restrain after)) {
  800. my $tt = $type;
  801. my $head = "$type parameters:\n";
  802. my $string = q{};
  803. foreach my $gds (@{ $self->parameters} ) {
  804. ## ## need to not lose guesses that get flagged as local by
  805. ## ## virtue of a math expression dependence
  806. ## if ( ($type eq 'lguess') and ($gds->type) and (not $gds->Use) ) {
  807. ## $string .= " " . $gds->report(0);
  808. ## next;
  809. ## };
  810. next if ($gds->[1] ne $type);
  811. next if (not $gds->[5]);
  812. my $toss = Demeter::GDS->new(name => $gds->[0],
  813. gds => $gds->[1],
  814. mathexp => $gds->[2],
  815. bestfit => $gds->[3],
  816. error => $gds->[4],
  817. );
  818. $string .= " " . $toss->report(0);
  819. $toss->DEMOLISH;
  820. };
  821. if ($string) {
  822. $text.= $head . $string . "\n";
  823. };
  824. };
  825. return $text;
  826. };
  827. sub fetch_statistics {
  828. my ($self) = @_;
  829. ## !!!! need to abstract out these words... see Demeter::Constants
  830. #foreach my $stat (qw(n_idp n_varys chi_square chi_reduced r_factor epsilon_k epsilon_r data_total)) {
  831. foreach my $stat (split(" ", $STATS)) {
  832. $self->$stat(sprintf("%.7f", $self->fetch_scalar($stat)));
  833. };
  834. ## in the case of a sum and with ifeffit, the stats cannot be obtained via the normal mechanism
  835. if ($self->n_idp == 0) {
  836. my $nidp = 0;
  837. foreach my $d (@ {$self->data} ) {
  838. $nidp += $d->nidp;
  839. };
  840. $nidp = 0 if ($nidp < 0);
  841. $self->n_idp(sprintf("%.3f", $nidp));
  842. };
  843. if ($self->n_varys == 0) {
  844. my $nv = 0;
  845. foreach my $g (@ {$self->gds} ) {
  846. ++$nv if ($g->gds eq 'guess');
  847. };
  848. $self->n_varys($nv);
  849. };
  850. if ($self->data_total == 0) {
  851. $self->data_total($#{ $self->data } + 1);
  852. };
  853. # if ($self->epsilon_k == 0) {
  854. # my $which = q{};
  855. # foreach my $d (@ {$self->data} ) {
  856. # ($which = $d) if ($d->fitting);
  857. # };
  858. # $self->epsilon_k($which->epsk);
  859. # $self->epsilon_r($which->epsr);
  860. # };
  861. return 0;
  862. };
  863. # sub statistics_report {
  864. # my ($self) = @_;
  865. # my %things = ("n_idp" => "Independent points ",
  866. # "n_varys" => "Number of variables ",
  867. # "chi_square" => "Chi-square ",
  868. # "chi_reduced" => "Reduced chi-square ",
  869. # "r_factor" => "R-factor ",
  870. # "epsilon_k" => "Measurement uncertainty (k) ",
  871. # "epsilon_r" => "Measurement uncertainty (R) ",
  872. # "data_total" => "Number of data sets ",
  873. # );
  874. # my $string = q{};
  875. # foreach my $stat (split(" ", $STAT_TEXT)) {
  876. # $string .= $self->template("report", "statistics", {name=>$things{$stat}, stat=>$stat});
  877. # ##$string .= sprintf("%s : %s\n", $things{$stat}, $self->$stat||0);
  878. # };
  879. # return $string;
  880. # };
  881. sub happiness_report {
  882. my ($self) = @_;
  883. my $string = sprintf("Happiness = %.5f / 100\t\tcolor = %s\n", $self->happiness, $self->color);
  884. foreach my $line (split "\n", $self->happiness_summary) {
  885. $string .= " $line\n";
  886. };
  887. $string .= "***** Note: happiness is a semantic parameter and should *****\n";
  888. $string .= "***** NEVER be reported in a publication -- NEVER! *****\n";
  889. return $string;
  890. };
  891. sub fetch_parameters {
  892. my ($self) = @_;
  893. $self->clear_parameters;
  894. foreach my $g (@ {$self->gds}) {
  895. $self->push_parameters([$g->name, $g->gds, $g->mathexp, $g->bestfit, $g->error, $g->Use]);
  896. };
  897. };
  898. ## handle correlations: store every correlation as attributes of the
  899. ## object. provide a variety of convenience functions for accessing
  900. ## this information as relatively flat data
  901. ## use the Mode objects feedback attribute (takes a coderef) to gather
  902. ## up the echo-ed text containing the correlations
  903. my @correl_text = ();
  904. sub fetch_correlations {
  905. my ($self) = @_;
  906. my %correlations_of;
  907. if (Demeter->is_ifeffit) {
  908. @correl_text = (); # initialize array buffer for accumulating correlations text
  909. my @save = ($self->toggle_echo(0), # turn screen echo off, saving prior state
  910. $self->get_mode("screen"),
  911. $self->get_mode("plotscreen"),
  912. $self->get_mode("feedback"));
  913. $self->set_mode(screen=>0, plotscreen=>0,
  914. feedback=>sub{push @correl_text, $_[0]}); # set feedback coderef
  915. my $d = $self -> data -> [0];
  916. #my $correl_lines;
  917. #$self->set_mode(buffer=>\$correl_lines);
  918. $self->dispense("fit", "correl");
  919. $self->toggle_echo($save[0]); # reset everything
  920. $self->set_mode(screen=>$save[1], plotscreen=>$save[2], feedback=>$save[3]);
  921. my @gds = map {lc($_->name)} @{ $self->gds };
  922. my $regex = Regexp::Assemble->new()->add(@gds)->re;
  923. foreach my $line (@correl_text) { # parse the correlations text
  924. if ($line =~ m{correl_
  925. ($regex)_ # first variable name followed by underscore
  926. ($regex) # second variable name
  927. \s+=\s+ # space equals space
  928. ($NUMBER) # a number
  929. }xi) {
  930. my ($x, $y, $correl) = ($1, $2, $3);
  931. #print join(" ", $x, $y, $correl), $/;
  932. $correlations_of{$x}{$y} = $correl;
  933. };
  934. if ($line =~ m{correl_
  935. (bkg\d\d_\d\d)_ # bkg parameter followed by an underscore
  936. ($regex) # variable name
  937. \s+=\s+ # space equals space
  938. ($NUMBER) # a number
  939. }xi) {
  940. my ($x, $y, $correl) = ($1, $2, $3);
  941. #print join(" ", $x, $y, $correl), $/;
  942. $correlations_of{$x}{$y} = $correl;
  943. };
  944. if ($self->co->default("fit", "bkg_corr")) {
  945. if ($line =~ m{correl_
  946. (bkg\d\d_\d\d)_ # bkg parameter followed by an underscore
  947. (bkg\d\d_\d\d) # another bkg parameter
  948. \s+=\s+ # space equals space
  949. ($NUMBER) # a number
  950. }xi) {
  951. my ($x, $y, $correl) = ($1, $2, $3);
  952. #print join(" ", $x, $y, $correl), $/;
  953. $correlations_of{$x}{$y} = $correl;
  954. };
  955. };
  956. };
  957. } elsif (Demeter->is_larch) {
  958. my @params = $self->fetch_array(join('.', $self->group, 'params', 'covar_vars'));
  959. foreach my $p1 (@params) {
  960. my %correls = $self->fetch_array(join('.', $self->group, 'params', $p1, 'correl'));
  961. foreach my $p2 (@params) {
  962. next if $p1 eq $p2;
  963. $correlations_of{$p1}{$p2} = $correls{$p2};
  964. };
  965. };
  966. };
  967. ##print Demeter->Dump([\%correlations_of]);
  968. foreach my $k (keys %correlations_of) {
  969. $self->set_correlations($k, $correlations_of{$k});
  970. };
  971. return 0;
  972. };
  973. sub fetch_pathresults {
  974. my ($self) = @_;
  975. $self->clear_pathresults;
  976. foreach my $p (@ {$self->paths}) {
  977. $self->push_pathresults([$p->data->group,
  978. $p->get(qw(name n s02_value sigma2_value
  979. e0_value delr_value reff
  980. ei_value third_value fourth_value include))]);
  981. };
  982. };
  983. sub correl {
  984. my ($self, $x, $y) = @_;
  985. my $value = ($self->exists_in_correlations($x)) ? $self->get_correlations($x)->{$y}
  986. : ($self->exists_in_correlations($y)) ? $self->get_correlations($y)->{$x}
  987. : 0;
  988. return $value;
  989. };
  990. sub all_correl {
  991. my ($self) = @_;
  992. my %all = ();
  993. my %seen = ();
  994. foreach my $x ($self->keys_in_correlations) {
  995. foreach my $y (keys %{ $self->get_correlations($x) } ) {
  996. my $key = join("|", $x, $y);
  997. next if $seen{join("|", $y, $x)};
  998. $all{$key} = $self->get_correlations($x)->{$y} || 0;
  999. ++$seen{$key};
  1000. };
  1001. };
  1002. return %all;
  1003. };
  1004. sub correl_report {
  1005. my ($self, $cormin) = @_;
  1006. my $string = "Correlations between variables:\n";
  1007. $cormin ||= $self->cormin;
  1008. my %all = $self->all_correl;
  1009. my @order = sort {abs($all{$b}) <=> abs($all{$a})} (keys %all);
  1010. foreach my $k (@order) {
  1011. last if (abs($all{$k}) < $cormin);
  1012. my ($x, $y) = split(/\|/, $k);
  1013. $string .= $self->template("report", "correl", {p1=>$x, p2=>$y, correl=>$all{$k}});
  1014. };
  1015. $string .= "All other correlations below $cormin\n" if $cormin;
  1016. return $string;
  1017. };
  1018. sub fetch_gds {
  1019. my ($self, $which) = @_;
  1020. $which = lc($which);
  1021. foreach my $g (@{$self->parameters}) {
  1022. return $g if ($which eq lc($g->[0]));
  1023. };
  1024. return 0;
  1025. };
  1026. sub has_data {
  1027. my ($self, $which) = @_;
  1028. foreach my $g (@{$self->data}) {
  1029. return 1 if ($which->group eq $g->group);
  1030. };
  1031. return 0;
  1032. };
  1033. sub repair_parameters {
  1034. my ($self) = @_;
  1035. my @params = @{$self->parameters};
  1036. my @repaired = ();
  1037. my %seen = ();
  1038. foreach my $p (@params) {
  1039. push @repaired, $p if not $seen{$p->[0]};
  1040. ++$seen{$p->[0]};
  1041. };
  1042. $self->parameters(\@repaired);
  1043. return $self;
  1044. };
  1045. sub grab { # deserialize lite -- grab the yaml
  1046. my ($self, @args) = @_; # without importing any data or paths
  1047. my %args = @args;
  1048. $args{plot} ||= 0;
  1049. $args{file} ||= 0;
  1050. $args{folder} ||= 0;
  1051. $args{regenerate} ||= 0;
  1052. my ($zip, $dpj, $yaml);
  1053. if ($args{file}) {
  1054. $dpj = File::Spec->rel2abs($args{file});
  1055. $self->start_spinner("Demeter is unpacking \"$args{file}\"") if ($self->mo->ui eq 'screen');
  1056. my $folder = $self->project_folder("raw_demeter");
  1057. $zip = Archive::Zip->new();
  1058. carp("Error reading project file ".$args{file}."\n\n"), return 1 unless ($zip->read($dpj) == AZ_OK);
  1059. };
  1060. ## -------- import the fit properties, statistics, correlations
  1061. $yaml = ($args{file}) ? $zip->contents("fit.yaml")
  1062. : $self->slurp(File::Spec->catfile($args{folder}, "fit.yaml"));
  1063. my $rhash = YAML::Tiny::Load($yaml);
  1064. my @array = %$rhash;
  1065. $self -> set(@array);
  1066. $self -> fit_performed(0);
  1067. my $structure = ($args{file}) ? $zip->contents('structure.yaml')
  1068. : $self->slurp(File::Spec->catfile($args{folder}, 'structure.yaml'));
  1069. my ($r_gdsnames, $r_data, $r_paths, $r_feff) = YAML::Tiny::Load($structure); # vpaths...
  1070. $self->datagroups($r_data);
  1071. my @data = ();
  1072. foreach my $d (@$r_data) {
  1073. #print join("|", $self->name, $d, $self->mo->fetch('Data', $d)), $/;
  1074. #print ">>>>>>> $d\n";
  1075. foreach my $which ('', '_standard') {
  1076. my $yaml = ($args{file}) ? $zip->contents("$d$which.yaml")
  1077. : $self->slurp(File::Spec->catfile($args{folder}, "$d$which.yaml"));
  1078. my ($r_attributes, $r_x, $r_y) = YAML::Tiny::Load($yaml);
  1079. ## the current implementation of XDI support has the xdifile attribute read-only if Xray::XDI is not available
  1080. delete $r_attributes->{xdifile} if (not $INC{'Xray/XDI.pm'});
  1081. delete $r_attributes->{fit_pcpath}; # correct an early
  1082. delete $r_attributes->{fit_do_pcpath}; # design mistake...
  1083. ## correct for earlier XDI design
  1084. foreach my $x (qw(xdi_mu_reference xdi_ring_current xdi_abscissa xdi_start_time
  1085. xdi_crystal xdi_focusing xdi_mu_transmission xdi_ring_energy
  1086. xdi_collimation xdi_d_spacing xdi_undulator_harmonic xdi_mu_fluorescence
  1087. xdi_end_time xdi_source xdi_edge_energy xdi_harmonic_rejection
  1088. xdi_mono xdi_sample xdi_scan xdi_extensions xdi_applications
  1089. xdi_labels xdi_detector xdi_beamline xdi_column xdi_comments xdi_version
  1090. xdi_facility
  1091. )) {
  1092. delete $r_attributes->{$x};
  1093. };
  1094. ## correct for change in energy-dependent normalization
  1095. delete $r_attributes->{bkg_fnorm};
  1096. # if (ref($r_attributes->{xdi_beamline}) ne 'HASH') {
  1097. # $r_attributes->{xdi_beamline} = {name=>$r_attributes->{xdi_beamline}||q{}};
  1098. # };
  1099. my %hash = %$r_attributes;
  1100. next if not exists $hash{group};
  1101. #Demeter->trace;
  1102. #print '>>>>', $hash{group}, $/;
  1103. my $savecv = $self->mo->datacount;
  1104. my $this = $self->mo->fetch('Data', $hash{group}) || Demeter::Data -> new(group=>$hash{group});
  1105. delete $hash{group};
  1106. $this->set(%hash);
  1107. if ($which eq '') {
  1108. $this->cv($r_attributes->{cv}||0);
  1109. $self->mo->datacount($savecv);
  1110. };
  1111. #$datae{$d} = $this;
  1112. #$datae{$this->group} = $this;
  1113. if ($this->datatype eq 'xmu') {
  1114. $this->dispense('fit', 'group');
  1115. $self->place_array($this->group.".energy", $r_x);
  1116. $self->place_array($this->group.".xmu", $r_y);
  1117. } elsif ($this->datatype eq 'chi') {
  1118. $this->dispense('fit', 'group');
  1119. $self->place_array($this->group.".k", $r_x);
  1120. $self->place_array($this->group.".chi", $r_y);
  1121. };
  1122. $this -> set(update_data=>0, update_columns=>0, fit_group=>q{});
  1123. push @data, $this;
  1124. };
  1125. };
  1126. $self->data(\@data);
  1127. $self->repair_parameters;
  1128. $self->grabbed(1);
  1129. $self->thawed(0);
  1130. };
  1131. ## ------------------------------------------------------------
  1132. ## Serialization and deserialization of the Fit object
  1133. override 'serialization' => sub {
  1134. my ($self) = @_;
  1135. my @gds = @{ $self->gds };
  1136. my @data = @{ $self->data };
  1137. my @paths = @{ $self->paths };
  1138. my @vpaths = @{ $self->vpaths };
  1139. my @gdsgroups = map { $_->group } @gds;
  1140. my @datagroups = map { $_->group } @data;
  1141. my @pathsgroups = map { $_->group } grep {defined $_} @paths;
  1142. my @feffgroups = map { $_ ? $_->group : q{} } map {$_ -> parent} grep {defined $_} @paths;
  1143. my @vpathsgroups = map { $_->group } grep {defined $_} @vpaths;
  1144. @feffgroups = uniq @feffgroups;
  1145. my $text = "# gdsgroups, datagroups, pathsgroups, feffgroups, vpathsgroups\n";
  1146. $text .= YAML::Tiny::Dump(\@gdsgroups, \@datagroups, \@pathsgroups, \@feffgroups, \@vpathsgroups);
  1147. $text .= "\n";
  1148. my %hash = $self->all;
  1149. $text .= YAML::Tiny::Dump(\%hash);
  1150. return $text;
  1151. };
  1152. override 'serialize' => sub {
  1153. my ($self, @args) = @_;
  1154. my %args = @args; # coerce args into a hash
  1155. $args{tree} ||= File::Spec->catfile($self->project_folder("raw_demeter"), 'fit');
  1156. $args{folder} ||= $self->group;
  1157. $args{file} ||= $args{project};
  1158. ($args{nozip} = 1) if not $args{file};
  1159. $args{copyfeff} ||= 1;
  1160. my @gds = @{ $self->gds };
  1161. my @data = @{ $self->data };
  1162. my @paths = @{ $self->paths };
  1163. my @vpaths = @{ $self->vpaths };
  1164. my @gdsgroups = map { $_->group } @gds;
  1165. my @datagroups = map { $_->group } @data;
  1166. my @pathsgroups = map { $_->group } grep {defined $_} @paths;
  1167. my @feffgroups = map { $_ ? $_->group : q{} } map {$_ -> parent} grep {defined $_} @paths;
  1168. my @vpathsgroups = map { $_->group } grep {defined $_} @vpaths;
  1169. @feffgroups = uniq @feffgroups;
  1170. unlink ($args{file}) if ($args{file} and (-e $args{file}));
  1171. $self->folder(File::Spec->catfile($args{tree}, $args{folder}));
  1172. mkpath($self->folder);
  1173. ## -------- save a yaml containing the structure of the fit
  1174. my $structure = File::Spec->catfile($self->folder, "structure.yaml");
  1175. open my $STRUCTURE, ">$structure";
  1176. print $STRUCTURE YAML::Tiny::Dump(\@gdsgroups, \@datagroups, \@pathsgroups, \@feffgroups, \@vpathsgroups);
  1177. close $STRUCTURE;
  1178. ## -------- save a yaml containing all GDS parameters
  1179. my $gdsfile = File::Spec->catfile($self->folder, "gds.yaml");
  1180. open my $gfile, ">$gdsfile";
  1181. foreach my $p (@gds) {
  1182. print $gfile $p->serialization;
  1183. };
  1184. close $gfile;
  1185. ## -------- save a yaml for each data file
  1186. foreach my $d (@data) {
  1187. my $dd = $d->group;
  1188. $d -> file($NULLFILE) if $d->prjrecord;
  1189. my $datafile = File::Spec->catfile($self->folder, "$dd.yaml");
  1190. $d -> serialization($datafile);
  1191. $d -> serialize($datafile);
  1192. if ($d->bkg_stan ne 'None') {
  1193. my $stan = $d->mo->fetch('Data', $d->bkg_stan);
  1194. $datafile = File::Spec->catfile($self->folder, $dd."_standard.yaml");
  1195. $stan -> serialization($datafile);
  1196. $stan -> serialize($datafile);
  1197. };
  1198. };
  1199. ## -------- save a yaml containing the paths
  1200. my $pathsfile = File::Spec->catfile($self->folder, "paths.yaml");
  1201. my %feffs = ();
  1202. open my $PATHS, ">$pathsfile";
  1203. foreach my $p (@paths) {
  1204. next if not defined($p);
  1205. print $PATHS $p->serialization;
  1206. if ($p->sp) { # this path used a ScatteringPath object
  1207. my $this = sprintf("%s", $p->parent);
  1208. $feffs{$this} = $p->get("parent");
  1209. } else { # this path imported a feffNNNN.dat file
  1210. 1;
  1211. };
  1212. };
  1213. close $PATHS;
  1214. ## -------- save a yaml containing the vpaths
  1215. my $vpathsfile = File::Spec->catfile($self->folder, "vpaths.yaml");
  1216. open my $VPATHS, ">$vpathsfile";
  1217. foreach my $vp (@vpaths) {
  1218. next if not defined($vp);
  1219. print $VPATHS $vp->serialization;
  1220. };
  1221. close $VPATHS;
  1222. ## -------- save yamls and phase.bin for the feff calculations (turn
  1223. ## this off in Artemis, where interaction with feff files
  1224. ## is handled somewhat differently)
  1225. if ($args{copyfeff}) {
  1226. foreach my $f (values %feffs) {
  1227. next if not defined($f);
  1228. my $ff = $f->group;
  1229. my $feffyaml = File::Spec->catfile($self->folder, $ff.".yaml");
  1230. $f->serialize($feffyaml, 1);
  1231. my $feff_from = File::Spec->catfile($f->get("workspace"), "original_feff.inp");
  1232. my $feff_to = File::Spec->catfile($self->folder, $ff.".inp");
  1233. copy($feff_from, $feff_to);
  1234. my $phase_from = File::Spec->catfile($f->get("workspace"), "phase.bin");
  1235. my $phase_to = File::Spec->catfile($self->folder, $ff.".bin");
  1236. copy($phase_from, $phase_to);
  1237. if (-e File::Spec->catfile($f->get("workspace"), "files.dat")) {
  1238. my $files_from = File::Spec->catfile($f->get("workspace"), "files.dat");
  1239. my $files_to = File::Spec->catfile($self->folder, $ff.".files");
  1240. copy($files_from, $files_to);
  1241. };
  1242. };
  1243. };
  1244. ## -------- save a yaml containing the fit properties
  1245. my @properties = grep {$_ !~ m{\A(?:gds|data|paths|vpaths|project|folder|rate|thingy|progress)\z}} $self->meta->get_attribute_list;
  1246. push @properties, 'name';
  1247. my @vals = $self->get(@properties);
  1248. my %props = zip(@properties, @vals);
  1249. my $propsfile = File::Spec->catfile($self->folder, "fit.yaml");
  1250. open my $PROPS, ">$propsfile";
  1251. print $PROPS YAML::Tiny::Dump(\%props);
  1252. close $PROPS;
  1253. ## -------- write fit and log files to the folder
  1254. foreach my $d (@data) {
  1255. my $dd = $d->group;
  1256. $d -> _update("bft");
  1257. $d -> dispense('fit', 'zeros') if not $self->fitted;
  1258. $d -> save("fit", File::Spec->catfile($self->folder, $dd.".fit"));
  1259. };
  1260. $self -> logfile(File::Spec->catfile($self->folder, "log"), $self->header, $self->footer);
  1261. ## -------- finally save a yaml containing the Plot object
  1262. my $plotfile = File::Spec->catfile($self->folder, "plot.yaml");
  1263. open my $PLOT, ">$plotfile";
  1264. print $PLOT $self->po->serialization;
  1265. close $PLOT;
  1266. if ($args{file}) {
  1267. my $readme = File::Spec->catfile($self->share_folder, "Readme.fit_serialization");
  1268. my $target = File::Spec->catfile($self->folder, "Readme");
  1269. copy($readme, $target);
  1270. open(my $touch, '>', File::Spec->catfile($self->folder, "FIT.SERIALIZATION"));
  1271. close $touch;
  1272. if (not $args{nozip}) {
  1273. $self->zip_project($self->folder, $args{file});
  1274. rmtree($self->folder);
  1275. };
  1276. };
  1277. return $self;
  1278. };
  1279. override 'deserialize' => sub {
  1280. my ($self, @args) = @_;
  1281. my %args = @args;
  1282. $args{plot} ||= 0;
  1283. $args{file} ||= 0;
  1284. $args{folder} ||= 0;
  1285. $args{regenerate} ||= 0;
  1286. my (%datae, %sps, %parents, $dpj, $zip, $project_folder);
  1287. if ($args{file}) {
  1288. $dpj = File::Spec->rel2abs($args{file});
  1289. $self->start_spinner("Demeter is unpacking \"$args{file}\"") if ($self->mo->ui eq 'screen');
  1290. my $folder = $self->project_folder("raw_demeter");
  1291. $zip = Archive::Zip->new();
  1292. carp("Error reading project file ".$args{file}."\n\n"), return 1 unless ($zip->read($dpj) == AZ_OK);
  1293. };
  1294. my $structure = ($args{file}) ? $zip->contents('structure.yaml')
  1295. : $self->slurp(File::Spec->catfile($args{folder}, 'structure.yaml'));
  1296. my ($r_gdsnames, $r_data, $r_paths, $r_feff) = YAML::Tiny::Load($structure); # vpaths...
  1297. $r_data = [] if not defined($r_data);
  1298. $self->datagroups($r_data);
  1299. ## -------- import the data
  1300. my @data = ();
  1301. $self->call_sentinal("Importing data");
  1302. foreach my $d (@$r_data) {
  1303. #print ">>>>>>> $d\n";
  1304. my $yaml = ($args{file}) ? $zip->contents("$d.yaml")
  1305. : $self->slurp(File::Spec->catfile($args{folder}, "$d.yaml"));
  1306. my ($r_attributes, $r_x, $r_y) = YAML::Tiny::Load($yaml);
  1307. ## the current implementation of XDI support has the xdifile attribute read-only if Xray::XDI is not available
  1308. delete $r_attributes->{xdifile} if (not $INC{'Xray/XDI.pm'});
  1309. delete $r_attributes->{fit_pcpath}; # correct an early
  1310. delete $r_attributes->{fit_do_pcpath}; # design mistake...
  1311. ## correct for change in energy-dependent normalization
  1312. delete $r_attributes->{bkg_fnorm};
  1313. ## clean up from old implementation(s) of XDI
  1314. foreach my $x (qw(xdi_mu_reference xdi_ring_current xdi_abscissa xdi_start_time
  1315. xdi_crystal xdi_focusing xdi_mu_transmission xdi_ring_energy
  1316. xdi_collimation xdi_d_spacing xdi_undulator_harmonic xdi_mu_fluorescence
  1317. xdi_end_time xdi_source xdi_edge_energy xdi_harmonic_rejection
  1318. xdi_mono xdi_sample xdi_scan xdi_extensions xdi_applications
  1319. xdi_labels xdi_detector xdi_beamline xdi_column xdi_comments xdi_version
  1320. xdi_facility
  1321. )) {
  1322. delete $r_attributes->{$x};
  1323. };
  1324. #if (ref($r_attributes->{xdi_beamline}) ne 'HASH') {
  1325. # $r_attributes->{xdi_beamline} = {name=>$r_attributes->{xdi_beamline}||q{}};
  1326. #};
  1327. my %hash = %$r_attributes;
  1328. next if not exists $hash{group};
  1329. #Demeter->trace;
  1330. #print '>>>>', $hash{group}, $/;
  1331. my $savecv = $self->mo->datacount;
  1332. my $this = $self->mo->fetch('Data', $hash{group}) || Demeter::Data -> new(group=>$hash{group});
  1333. delete $hash{group};
  1334. $this->set(%hash);
  1335. $this->from_yaml(1);
  1336. $this->cv($r_attributes->{cv}||0);
  1337. $self->mo->datacount($savecv);
  1338. $datae{$d} = $this;
  1339. $datae{$this->group} = $this;
  1340. $this->dispense('process', 'group') if Demeter->is_larch;
  1341. if ($this->datatype eq 'xmu') {
  1342. $self->place_array($this->group.".energy", $r_x);
  1343. $self->place_array($this->group.".xmu", $r_y);
  1344. } elsif ($this->datatype eq 'chi') {
  1345. $self->place_array($this->group.".k", $r_x);
  1346. $self->place_array($this->group.".chi", $r_y);
  1347. };
  1348. $this -> set(update_data=>0, update_columns=>0, update_norm=>1);
  1349. push @data, $this;
  1350. };
  1351. ## -------- import the gds
  1352. my @gds = ();
  1353. $self->call_sentinal("Importing GDS parameters");
  1354. my $yaml = ($args{file}) ? $zip->contents("gds.yaml")
  1355. : $self->slurp(File::Spec->catfile($args{folder}, "gds.yaml"));
  1356. my @list = YAML::Tiny::Load($yaml);
  1357. foreach (@list) {
  1358. my %hash = %{ $_ };
  1359. $hash{initial} ||= q{};
  1360. my $this = Demeter::GDS->new(%hash);
  1361. push @gds, $this;
  1362. my $command;
  1363. if ($this->gds eq 'guess') {
  1364. #$command = sprintf "guess %s = %f\n", $this->name, $this->bestfit;
  1365. $command = $this->template('fit', 'gds')
  1366. } elsif ($this->gds =~ m{\A(?:def|after)}) {
  1367. #$command = sprintf "def %s = %s\n", $this->name, $this->mathexp;
  1368. $command = $this->template('fit', 'gds')
  1369. } elsif ($this->gds eq 'set') {
  1370. #$command = sprintf "set %s = %s\n", $this->name, $this->mathexp;
  1371. $command = $this->template('fit', 'gds')
  1372. };
  1373. ## restrain, skip, after, (merge, penalty) should not be disposed at this time
  1374. if ($this->gds =~ m{(?:guess|def|set)}) {
  1375. $this->dispose($command);
  1376. };
  1377. };
  1378. ## -------- import the feff calculations
  1379. my @feff = ();
  1380. $self->call_sentinal("Importing Feff calculations");
  1381. if ($args{file}) {
  1382. foreach my $f (@$r_feff) {
  1383. #my $ws = $f->workspace;
  1384. #$ws =~ s{\\}{/}g; # path separators...
  1385. #my $where = Cwd::realpath(File::Spec->catfile($args{folder}, '..', '..', 'feff', basename($ws)));
  1386. my $where = "";
  1387. my $this = Demeter::Feff->new(group=>$f); #, workspace=>$where);
  1388. $parents{$this->group} = $this;
  1389. my $yaml = ($args{file}) ? $zip->contents("$f.yaml")
  1390. : $self->slurp(File::Spec->catfile($args{folder}, "$f.yaml"));
  1391. if (defined $yaml) {
  1392. my @refs = YAML::Tiny::Load($yaml);
  1393. $this->read_yaml(\@refs, $where);
  1394. foreach my $s (@{ $this->pathlist }) {
  1395. $sps{$s->group} = $s
  1396. };
  1397. push @feff, $this;
  1398. };
  1399. };
  1400. };
  1401. ## -------- import the paths
  1402. my @paths = ();
  1403. $self->call_sentinal("Importing paths");
  1404. $yaml = ($args{file}) ? $zip->contents("paths.yaml")
  1405. : $self->slurp(File::Spec->catfile($args{folder}, "paths.yaml"));
  1406. #print File::Spec->catfile($args{folder}, "paths.yaml"),$/;
  1407. @list = YAML::Tiny::Load($yaml);
  1408. my $i=0;
  1409. foreach my $pathlike (@list) {
  1410. my $dg = $pathlike->{datagroup};
  1411. $pathlike->{data} = $datae{$dg} || Demeter->mo->fetch('Data', $dg);
  1412. #Demeter->trace;
  1413. if (exists $pathlike->{absorber}) { # this is an FSPath
  1414. delete $pathlike->{$_} foreach qw(workspace Type weight string pathtype plottable);
  1415. } elsif (exists $pathlike->{ipot}) { # this is an SSPath
  1416. delete $pathlike->{$_} foreach qw(Type weight string pathtype plottable);
  1417. } elsif (exists $pathlike->{nnnntext}) { # this is an FPath
  1418. 1;
  1419. };
  1420. my %hash = %{ $pathlike };
  1421. if (not $Demeter::XDI_exists) {
  1422. delete($hash{xdifile});
  1423. delete($hash{xdi});
  1424. delete($hash{xdi_will_be_cloned});
  1425. };
  1426. my $this;
  1427. if (exists $pathlike->{ipot}) { # this is an SSPath
  1428. my $feff = $parents{$pathlike->{parentgroup}} || $data[0] -> mo -> fetch('Feff', $pathlike->{parentgroup});
  1429. $this = Demeter::SSPath->new(parent=>$feff);
  1430. $this -> set(%hash);
  1431. $this -> sp($this);
  1432. ##print $this->group, " ", $this->name, " ", $this->parent->group, $/;
  1433. } elsif (exists $pathlike->{nnnntext}) { # this is an FPath
  1434. $this = Demeter::FPath->new();
  1435. $this -> set(%hash);
  1436. $this -> sp($this);
  1437. $this -> parentgroup($this->group);
  1438. $this -> parent($this);
  1439. $this -> workspace($this->stash_folder);
  1440. } elsif (exists $pathlike->{absorber}) { # this is an FSPath
  1441. #my $feff = $parents{$pathlike->{parentgroup}} || $data[0] -> mo -> fetch('Feff', $pathlike->{parentgroup});
  1442. my $feff = Demeter -> mo -> fetch('Feff', $pathlike->{parentgroup});
  1443. $feff = Demeter -> mo -> fetch('Feff', basename($pathlike->{folder})) if (ref($feff) !~ m{Feff});
  1444. #my $ws = $feff->workspace;
  1445. #$ws =~ s{\\}{/}g; # path separators...
  1446. #my $where = Cwd::realpath(File::Spec->catfile($args{folder}, '..', '..', 'feff', basename($ws)));
  1447. ## there is a situation (not yet understood) where a path on Windows gets saved with \ rather than /
  1448. my $ws = basename($pathlike->{folder});
  1449. if (length($ws) != 5) {
  1450. my $save = fileparse_set_fstype();
  1451. fileparse_set_fstype('MSWin32');
  1452. $ws = basename($pathlike->{folder});
  1453. fileparse_set_fstype($save);
  1454. };
  1455. my $where = Cwd::realpath(File::Spec->catfile($args{folder}, '..', '..', 'feff', $ws));
  1456. $feff->workspace($where);
  1457. $this = $self->mo->fetch("FSPath", $hash{group}) || Demeter::FSPath->new();
  1458. $this->feff_done(0);
  1459. $hash{folder} = $where;
  1460. $hash{update_path} = 1;
  1461. $hash{update_fft} = 1;
  1462. $hash{update_bft} = 1;
  1463. foreach my $att (qw(feff_done workspace folder)) {
  1464. delete $hash{$att};
  1465. };
  1466. $this -> sp($this -> mo -> fetch('ScatteringPath', $this->spgroup));
  1467. $this -> set(%hash);
  1468. $this -> set(make_gds => 0, parent=>$feff, parentgroup=>$feff->group);
  1469. $this -> set(workspace=>$where, folder=>$where);
  1470. foreach my $att (qw(e0 s02 delr sigma2 third fourth)) {
  1471. $this->$att($hash{$att});
  1472. };
  1473. } else {
  1474. $hash{data} ||= $self->mo->fetch('Data', $hash{datagroup});
  1475. $this = Demeter::Path->new(%hash);
  1476. my $sp = $sps{$this->spgroup} || $self -> mo -> fetch('ScatteringPath', $this->spgroup);
  1477. $this -> sp($sp);
  1478. #$this -> folder(q{});
  1479. #print $this, " ", $this->sp, $/;
  1480. };
  1481. $this -> datagroup($dg);
  1482. ## reconnect object relationships
  1483. $this -> parent($parents{$this->parentgroup}) if (ref($this) !~ m{FPath});
  1484. $this -> data($datae{$this->datagroup});
  1485. push @paths, $this;
  1486. };
  1487. ## -------- import the vpaths
  1488. my @vpaths = ();
  1489. $yaml = ($args{file}) ? $zip->contents("vpaths.yaml")
  1490. : $self->slurp(File::Spec->catfile($args{folder}, "vpaths.yaml"));
  1491. if ($yaml) {
  1492. $self->call_sentinal("Importing VPaths");
  1493. @list = YAML::Tiny::Load($yaml);
  1494. foreach my $vp (@list) {
  1495. next if Demeter->mo->fetch('VPath', $vp->{group});
  1496. delete $vp->{$_} foreach qw(id update_path update_fft update_bft);
  1497. my $dg = $vp->{datagroup};
  1498. $vp->{data} = $datae{$dg};
  1499. my @pathgroups = @{ $vp->{pathgroups} };
  1500. my @array = %{ $vp };
  1501. my $this = Demeter::VPath->new();
  1502. $this -> set(@array);
  1503. $this -> update_path(1);
  1504. foreach my $pg (@pathgroups) {
  1505. my $path = $this -> mo -> fetch(['Path','SSPath'], $pg);
  1506. $path->parent(Demeter->mo->fetch("Feff", $path->parentgroup)) if not $path->parent;
  1507. ##print $path->name, "|", $path->group, "|", $path->parent, $/;
  1508. $this->push_paths($path);
  1509. };
  1510. push @vpaths, $this;
  1511. };
  1512. };
  1513. if ($args{regenerate}) {
  1514. my %mapping = ();
  1515. foreach my $o (@gds, @data, @paths) {
  1516. my $old = $o->group;
  1517. my $new = $o->_get_group;
  1518. $o->group($new);
  1519. $mapping{$old} = $new;
  1520. $mapping{$new} = $old;
  1521. };
  1522. ## need to fix group values inside yaml files also!!
  1523. foreach my $d (@data) {
  1524. move(File::Spec->catfile($args{folder}, $mapping{$d->group}.".fit" ), File::Spec->catfile($args{folder}, $d->group.".fit" ));
  1525. move(File::Spec->catfile($args{folder}, $mapping{$d->group}.".yaml"), File::Spec->catfile($args{folder}, $d->group.".yaml"));
  1526. };
  1527. foreach my $p (@paths) {
  1528. my $olddatagroup = $p->datagroup;
  1529. $p->datagroup($mapping{$olddatagroup});
  1530. $p->data($p->mo->fetch('Data', $p->datagroup));
  1531. };
  1532. };
  1533. ## -------- make the fit object
  1534. $self->call_sentinal("Making Fit object");
  1535. $self -> set(gds => \@gds,
  1536. data => \@data,
  1537. paths => \@paths,
  1538. );
  1539. $self->vpaths(\@vpaths) if ($#vpaths > -1);
  1540. #$self->repair_parameters;
  1541. ## -------- import the fit properties, statistics, correlations
  1542. $yaml = ($args{file}) ? $zip->contents("fit.yaml")
  1543. : $self->slurp(File::Spec->catfile($args{folder}, "fit.yaml"));
  1544. # Demeter->trace;
  1545. # print $args{file}, " ", $args{folder}, $/;
  1546. # print $yaml, $/;
  1547. my $rhash = YAML::Tiny::Load($yaml) || {};
  1548. my @array = %$rhash;
  1549. $self -> set(@array);
  1550. $self -> fit_performed(0);
  1551. ## -------- extract files from the feff calculations from the project
  1552. $self->call_sentinal("Extracting Feff files");
  1553. if ($args{file}) {
  1554. $project_folder = $self->project_folder("fit_".$self->group);
  1555. $self->folder($project_folder);
  1556. # $location_of{ident $fitobject} = $project_folder;
  1557. foreach my $f (@feff) {
  1558. my $ff = $f->group;
  1559. my $feff_folder = File::Spec->catfile($project_folder, "feff_".$ff);
  1560. mkpath($feff_folder);
  1561. my $thisdir = cwd;
  1562. chdir $feff_folder;
  1563. my $ok = 0;
  1564. # $ok = $zip -> extractMemberWithoutPaths("$f.inp");
  1565. # croak("Demeter::Fit::deserialize: could not extract $f.inp from $dpj") if ($ok != AZ_OK);
  1566. # rename("$f.inp", "oringinal_feff.inp");
  1567. $ok = $zip -> extractMemberWithoutPaths("$ff.yaml");
  1568. croak("Demeter::Fit::deserialize: could not extract $f.yaml from $dpj") if ($ok != AZ_OK);
  1569. rename("$ff.yaml", "feff.yaml");
  1570. $ok = $zip -> extractMemberWithoutPaths("$ff.bin");
  1571. croak("Demeter::Fit::deserialize: could not extract $f.bin from $dpj") if ($ok != AZ_OK);
  1572. rename("$ff.bin", "phase.bin");
  1573. $ok = $zip -> extractMemberWithoutPaths("$ff.files");
  1574. croak("Demeter::Fit::deserialize: could not extract $f.files from $dpj") if ($ok != AZ_OK);
  1575. rename("$ff.files", "files.dat");
  1576. chdir $thisdir;
  1577. };
  1578. };
  1579. ## -------- import the fit files and push arrays into Ifeffit/Larch
  1580. $self->call_sentinal("Pushing arrays");
  1581. foreach my $d (@data) {
  1582. my $dd = $d->group;
  1583. ## import the fit data
  1584. my $file;
  1585. if ($args{file}) {
  1586. my $thisdir = cwd;
  1587. chdir $self->stash_folder;
  1588. $zip -> extractMemberWithoutPaths("$dd.fit");
  1589. chdir $thisdir;
  1590. $file = File::Spec->catfile($self->stash_folder, "$dd.fit");
  1591. } elsif ($args{folder}) {
  1592. $file = File::Spec->catfile($args{folder}, "$dd.fit");
  1593. $project_folder = $args{folder};
  1594. };
  1595. $d->read_fit($file) if (-e $file);
  1596. $d->fitting(1);
  1597. $d->fit_group(q{});
  1598. #unlink $file; # why would I want to do this?
  1599. };
  1600. ## -------- import the Plot object, if requested
  1601. $self->call_sentinal("Importing Plot object");
  1602. if ($args{plot}) {
  1603. $yaml = ($args{file}) ? $zip->contents("plot.yaml")
  1604. : $self->slurp(File::Spec->catfile($args{folder}, "plot.yaml"));
  1605. my $rhash = YAML::Tiny::Load($yaml);
  1606. my @array = %$rhash;
  1607. $self -> po -> set(@array);
  1608. };
  1609. $self->grabbed(1);
  1610. $self->thawed(1);
  1611. $self->location($project_folder||q{});
  1612. $self->stop_spinner if ($self->mo->ui eq 'screen');
  1613. return $self;
  1614. };
  1615. alias freeze => 'serialize';
  1616. alias thaw => 'deserialize';
  1617. __PACKAGE__->meta->make_immutable;
  1618. 1;
  1619. =head1 NAME
  1620. Demeter::Fit - Fit EXAFS data using Ifeffit or Larch
  1621. =head1 VERSION
  1622. This documentation refers to Demeter version 0.9.26.
  1623. =head1 SYNOPSIS
  1624. my $fitobject = Demeter::Fit -> new(gds => \@gds_objects,
  1625. data => [$data_object],
  1626. paths => \@path_objects,
  1627. );
  1628. $fitobject -> fit;
  1629. $fitobject -> evaluate;
  1630. $fitobject -> logfile("cufit.log");
  1631. =head1 DESCRIPTION
  1632. This class collects and organizes all the components of a fit using
  1633. Ifeffit or Larch. The bulk of a script to fit EXAFS data involves
  1634. setting up all the data, paths, and parameters that go into the fit.
  1635. Once that is done, you pass that information to the Fit object as
  1636. array references. It collates all of the information, resolves the
  1637. connections between Path and Data objects, performs a number of sanity
  1638. checks on the input information, and generates the sequence of Ifeffit
  1639. or Larch commands needed to perform the fit. After the hard work of
  1640. setting up the Data, Path, and GDS objects is done, you are just a few
  1641. lines away from a complete fitting script!
  1642. =head1 ATTRIBUTES
  1643. Three attributes define a fit. These are C<gds>, C<data>, and
  1644. C<paths>. Each takes an reference to an array of other objects. The
  1645. C<gds> attribute takes a reference to an array of GDS objects, and so
  1646. on. All other attributes of a Fit object are scalar valued.
  1647. The C<set> method will throw an exception if the argument to C<gds>,
  1648. C<data>, and C<paths> is not a reference to an array. Similarly, the
  1649. C<get> method returns array references for those three attributes.
  1650. Here is a list of the scalar valued attributes. Many of these get set
  1651. automatically when the fit is performed. All of them are optional.
  1652. =over 4
  1653. =item C<vpaths>
  1654. Like the C<gds>, C<data>, and C<paths> attributes, this takes a
  1655. reference to an array. This array contains all the
  1656. L<VPath|Demeter::VPath> objects defined with the fit. Note that,
  1657. unlike the other three, this is not required and is not a part of the
  1658. definition of the fit. In fact, the only use for this attribute is to
  1659. have a collection of VPaths saved to a serialization file and
  1660. recovered when the fit is deserialized.
  1661. =item C<label>
  1662. Short descriptive text for this fit.
  1663. =item C<description>
  1664. Longer descriptive text for this fit. This will be written to the log
  1665. file after a fit.
  1666. =item C<fom>
  1667. A figure of merit for this fit. This is intended for reports on
  1668. multiple fits. An example might be the temperature of the data fit
  1669. where the report is then intended to show the temperature dependence
  1670. of the fit.
  1671. =item C<environment>
  1672. This is filled in with information about the versions of Demeter and
  1673. perl and the operating system used.
  1674. =item C<interface>
  1675. This is filled in with text identifying the user interface. The
  1676. default value is 'Demeter-based script'. This should be set to the
  1677. name of the program using Demeter.
  1678. =item C<time_of_fit>
  1679. This is filled in with the time stamp when the fit finishes.
  1680. =item C<prepared_by>
  1681. This is filled in with an attempt to identify the person performing
  1682. the fit.
  1683. =item C<contact>
  1684. This may be filled in with information about how to contact the person
  1685. performing the fit.
  1686. =item C<cormin>
  1687. Minimum correlation reported in the log file. This must be a number
  1688. between 0 and 1.
  1689. =item C<ignore_nidp>
  1690. If this boolean attribute is true, Demeter will not perform the sanity
  1691. check which verifies that the number of guess parameters is smaller
  1692. than the number of independent points. Just because this parameter
  1693. exists, B<do not> presume that this is a good idea. If you run a fit
  1694. with too many free parameters, best fit values, error bars and
  1695. correlations will not be meaningful and the fit that you run cannot be
  1696. reliably interpreted in a statistical sense.
  1697. =back
  1698. =head1 METHODS
  1699. =over 4
  1700. =item C<fit>
  1701. This method returns the sequence of commands to perform a fit in
  1702. Ifeffit or Larch. This sequence will include lines defining each
  1703. guess, def, set, and restrain parameter. The data will be imported by
  1704. the C<read_data> command. Each path associated with the data set will
  1705. be defined. Then the text of the Ifeffit's C<feffit> or Larch's
  1706. C<...> command is generated. Finally, commands for defining the after
  1707. parameters and for computing the residual arrays are made.
  1708. $fitobject -> fit;
  1709. A number of sanity checks are made on the fitting model before the fit is
  1710. performed. For the complete list of these sanity checks, see
  1711. L<Demeter::Fit::Sanity>.
  1712. =item C<sum>
  1713. This method returns a VPath object containing all paths associated
  1714. with the fit and with the specified Data object. If the data argument
  1715. is not supplied, the first data set in the C<data> attribute will be
  1716. used. Ths, for a one-data-set fit, the data argument is optional.
  1717. my $sum = $fit->sum($data);
  1718. $data -> plot('r');
  1719. $sum -> plot('r');
  1720. =item C<rm>
  1721. Clean up all on-disk trace of this fit project, typically at the end
  1722. of script involving deserialization of project file.
  1723. $fitobject -> rm;
  1724. =item C<gds>
  1725. This method returns a reference to the list of GDS objects in this fit.
  1726. @list_of_parameters = @{ $fit -> gds };
  1727. =item C<data>
  1728. This method returns a reference to the list of Data objects in this fit.
  1729. @list_of_data = @{ $fit -> data };
  1730. =item C<paths>
  1731. This method returns a reference to the list of Path objects in this fit.
  1732. @list_of_paths = @{ $fit -> paths };
  1733. =item C<set_all>
  1734. NOT WORKING AT THIS TIME.
  1735. This method is used to set attributes of every Data, Path, or GDS in a
  1736. fit. For instance, this example sets C<rmin> for each data set to 1.2:
  1737. $fitobject -> set_all('data', {rmin=>1.2});
  1738. This example sets the C<sigma2> math expression for each Path in the
  1739. fit:
  1740. $fitobject -> set_all('path', {sigma2=>'debye(temp, thetad)'});
  1741. This example converts all parameters to be set parameters:
  1742. $fitobject -> set_all('gds', {type => 'set'});
  1743. The first argument is one of "data", "paths", "gds" and the second is
  1744. a reference to a hash of valid attributes for the object type.
  1745. This returns the Fit object reference if the arguments can be properly
  1746. interpreted and return 0 otherwise.
  1747. =item C<evaluate>
  1748. This method is called after the C<fit> or C<ff2chi> method. This will
  1749. evaluate all path parameters, all GDS parameters, and all correlations
  1750. between guess parameters and store them in the appropriate objects.
  1751. This is always called by the C<fit> method once the fit is finished,
  1752. thus it is rarely necessary for you to need to make an explicit call.
  1753. $fitobject -> fit;
  1754. $fitobject -> evaluate;
  1755. =item C<logfile>
  1756. This write a log file from the results of a fit and an ff2chi.
  1757. $fitobject -> logfile($filename, $header, $footer);
  1758. The first argument is the name of the output file. The other two
  1759. arguments are arbitrary text that will be added to the top and bottom
  1760. of the log file.
  1761. =item C<statistic>
  1762. This returns the value of one of the fitting statistics, assuming the
  1763. C<evaluate> method has been called.
  1764. $fitobject -> statistic("chi_reduced");
  1765. An exception is thrown is the argument is not one of the following:
  1766. n_idp n_varys chi_square chi_reduced r_factor
  1767. epsilon_k epsilon_r data_total
  1768. =item C<correl>
  1769. This returns the correlation between any two parameters, assuming the
  1770. C<evaluate> method has been called.
  1771. my $cor = $fitobject->correl("delr", "enot");
  1772. =item C<all_correl>
  1773. This returns a complete hash of correlations between parameters,
  1774. assuming the C<evaluate> method has been called.
  1775. my %correls = $fitobject -> all_correl;
  1776. =item C<correl_report>
  1777. This method returns a block of text summarizing all the correlations
  1778. above the value given as the first argument, assuming the C<evaluate>
  1779. method has been called. This method is used by the C<logfile> method.
  1780. my $text = $fitobject -> correl_report(0.4);
  1781. =item C<happiness>
  1782. This returns the happiness evaluation of the fit and is writtent to
  1783. the log file. The two return values are the happiness measurement and
  1784. a text summary of how the happiness was evaluated. See
  1785. L<Demeter::Fit::Happiness>.
  1786. ($happiness, $summery) = $fit -> happiness;
  1787. =back
  1788. =head1 SERIALIZATION AND DESERIALIZATION
  1789. A fit can be serialized to a zip file containing YAML serializations
  1790. of the various parts of the fit.
  1791. $fitobject->serialize("projectfile");
  1792. One of these zip files can be deserialized to a Fit object:
  1793. $newfitobject = Demeter::Fit->new(project=>"projectfile");
  1794. The files are normal zip files and can be opened using a normal zip
  1795. tool.
  1796. C<freeze> and C<thaw> are aliases for the C<serialize> and
  1797. C<deserialize> methods.
  1798. The constituents of the deserialized fit can be recovered by
  1799. dereferencing the arrays stored in the C<gds>, C<data>, and C<paths>
  1800. attributes.
  1801. my @gds = @{ $newfitobject->gds };
  1802. my @data = @{ $newfitobject->data };
  1803. my @paths = @{ $newfitobject->paths };
  1804. =head1 DIAGNOSTICS
  1805. These messages are classified as follows (listed in increasing order
  1806. of desperation):
  1807. (W) A warning (optional).
  1808. (F) A fatal error (trappable).
  1809. =over 4
  1810. =item Demeter::Fit: component not an array reference
  1811. (F) You have attempted to set one of the array-valued Fit attributes
  1812. to something that is not a reference to an array.
  1813. =item Demeter::Fit: <key> is not a component of this fit
  1814. (W) You have attempted to get an attribute value that is not one of
  1815. C<gds>, C<data>, C<paths> or one of the scalar values.
  1816. =item No gds component is defined for this fit
  1817. =item No data component is defined for this fit
  1818. =item No paths component is defined for this fit
  1819. (F) You have neglected to define one of the attributes of the Fit
  1820. object.
  1821. =item This fit is ill-defined. Giving up...
  1822. =item This summation is ill-defined. Giving up...
  1823. (F) One or more of the sanity checks has failed. Other
  1824. diagnostic messages with more details will be issued.
  1825. =item '$stat' is not a fitting statistic ($STAT_TEXT)
  1826. (W) You have asked for a fitting statitstic that is not one of the
  1827. ones available (n_idp n_varys chi_square chi_reduced r_factor
  1828. epsilon_k epsilon_r data_total).
  1829. =back
  1830. =head1 CONFIGURATION AND ENVIRONMENT
  1831. See L<Demeter::Config> for a description of the configuration system.
  1832. See the fit group of configuration parameters.
  1833. =head1 DEPENDENCIES
  1834. The dependencies of the Demeter system are in the
  1835. F<Build.PL> file.
  1836. =head1 BUGS AND LIMITATIONS
  1837. =over 4
  1838. =item *
  1839. It is not clear how serialization and deserialization will work in the
  1840. context of an artemis project with multiple fits conatined in one file.
  1841. =item *
  1842. The log file should be structured by using templates.
  1843. =item *
  1844. set_all method not implemented
  1845. =back
  1846. Please report problems to the Ifeffit Mailing List
  1847. (L<http://cars9.uchicago.edu/mailman/listinfo/ifeffit/>)
  1848. Patches are welcome.
  1849. =head1 AUTHOR
  1850. Bruce Ravel, L<http://bruceravel.github.io/home>
  1851. L<http://bruceravel.github.io/demeter/>
  1852. =head1 LICENCE AND COPYRIGHT
  1853. Copyright (c) 2006-2017 Bruce Ravel (L<http://bruceravel.github.io/home>). All rights reserved.
  1854. This module is free software; you can redistribute it and/or
  1855. modify it under the same terms as Perl itself. See L<perlgpl>.
  1856. This program is distributed in the hope that it will be useful,
  1857. but WITHOUT ANY WARRANTY; without even the implied warranty of
  1858. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  1859. =cut