Commit | Line | Data |
5c9ecf66 |
1 | package stemmaweb::Controller::Stexaminer; |
2376359f |
2 | use Moose; |
3 | use namespace::autoclean; |
f8d13166 |
4 | use Encode qw/ decode_utf8 /; |
2376359f |
5 | use File::Temp; |
6 | use JSON; |
a44aaf2a |
7 | use Text::Tradition::Analysis qw/ run_analysis wit_stringify /; |
f8d13166 |
8 | use Text::Tradition::Collation; |
9 | use Text::Tradition::Stemma; |
2376359f |
10 | |
11 | BEGIN { extends 'Catalyst::Controller' } |
12 | |
13 | |
14 | =head1 NAME |
15 | |
5c9ecf66 |
16 | stemmaweb::Controller::Stexaminer - Simple controller for stemma display |
2376359f |
17 | |
18 | =head1 DESCRIPTION |
19 | |
20 | The stemma analysis tool with the pretty colored table. |
21 | |
22 | =head1 METHODS |
23 | |
f8d13166 |
24 | =head2 index |
25 | |
3524c08f |
26 | GET stexaminer/$textid/$stemmaid |
2376359f |
27 | |
3524c08f |
28 | Renders the application for the text identified by $textid, using the stemma |
29 | graph identified by $stemmaid. |
2376359f |
30 | |
2376359f |
31 | =cut |
32 | |
3524c08f |
33 | sub index :Path :Args(2) { |
34 | my( $self, $c, $textid, $stemid ) = @_; |
2376359f |
35 | my $m = $c->model('Directory'); |
36 | my $tradition = $m->tradition( $textid ); |
52dcc672 |
37 | my $ok = _check_permission( $c, $tradition ); |
38 | return unless $ok; |
1c0900ef |
39 | if( $tradition->stemma_count ) { |
40 | my $stemma = $tradition->stemma(0); |
f8d13166 |
41 | $c->stash->{svg} = $stemma->as_svg( { size => [ 600, 350 ] } ); |
42 | $c->stash->{graphdot} = $stemma->editable({ linesep => ' ' }); |
1c0900ef |
43 | $c->stash->{text_title} = $tradition->name; |
44 | $c->stash->{template} = 'stexaminer.tt'; |
e217c221 |
45 | |
46 | # Get the analysis options |
47 | my( $use_type1, $ignore_sort ) = ( 0, 'none' ); |
cc79edd2 |
48 | $use_type1 = $c->req->param( 'show_type1' ) ? 1 : 0; |
49 | $ignore_sort = $c->req->param( 'ignore_variant' ) || ''; |
e217c221 |
50 | $c->stash->{'show_type1'} = $use_type1; |
51 | $c->stash->{'ignore_variant'} = $ignore_sort; |
1c0900ef |
52 | # TODO Run the analysis as AJAX from the loaded page. |
3524c08f |
53 | my %analysis_options = ( |
54 | stemma_id => $stemid, |
55 | exclude_type1 => !$use_type1 ); |
e217c221 |
56 | if( $ignore_sort eq 'spelling' ) { |
7b7abf10 |
57 | $analysis_options{'merge_types'} = [ qw/ spelling orthographic / ]; |
e217c221 |
58 | } elsif( $ignore_sort eq 'orthographic' ) { |
7b7abf10 |
59 | $analysis_options{'merge_types'} = 'orthographic'; |
e217c221 |
60 | } |
cc79edd2 |
61 | |
62 | # Do the deed |
e217c221 |
63 | my $t = run_analysis( $tradition, %analysis_options ); |
a44aaf2a |
64 | # Stringify the reading groups |
65 | foreach my $loc ( @{$t->{'variants'}} ) { |
66 | my $mst = wit_stringify( $loc->{'missing'} ); |
67 | $loc->{'missing'} = $mst; |
68 | foreach my $rhash ( @{$loc->{'readings'}} ) { |
69 | my $gst = wit_stringify( $rhash->{'group'} ); |
70 | $rhash->{'group'} = $gst; |
ee53ab0d |
71 | _stringify_element( $rhash, 'independent_occurrence' ); |
72 | _stringify_element( $rhash, 'reversions' ); |
e41080b6 |
73 | unless( $rhash->{'text'} ) { |
74 | $rhash->{'text'} = $rhash->{'readingid'}; |
75 | } |
a44aaf2a |
76 | } |
77 | } |
23306161 |
78 | # Values for TT rendering |
1c0900ef |
79 | $c->stash->{variants} = $t->{'variants'}; |
80 | $c->stash->{total} = $t->{'variant_count'}; |
81 | $c->stash->{genealogical} = $t->{'genealogical_count'}; |
23306161 |
82 | $c->stash->{conflict} = $t->{'conflict_count'}; |
83 | # Also make a JSON stash of the data for the statistics tables |
84 | $c->stash->{reading_statistics} = to_json( $t->{'variants'} ); |
1c0900ef |
85 | } else { |
86 | $c->stash->{error} = 'Tradition ' . $tradition->name |
87 | . 'has no stemma for analysis.'; |
88 | } |
2376359f |
89 | } |
90 | |
ee53ab0d |
91 | sub _stringify_element { |
92 | my( $hash, $key ) = @_; |
b203d1c4 |
93 | return undef unless exists $hash->{$key}; |
94 | if( ref( $hash->{$key} ) eq 'ARRAY' ) { |
95 | my $str = join( ', ', @{$hash->{$key}} ); |
96 | $hash->{$key} = $str; |
97 | } |
ee53ab0d |
98 | } |
99 | |
52dcc672 |
100 | sub _check_permission { |
101 | my( $c, $tradition ) = @_; |
102 | my $user = $c->user_exists ? $c->user->get_object : undef; |
103 | if( $user ) { |
104 | $c->stash->{'permission'} = 'full' |
a55f7ff6 |
105 | if( $user->is_admin || |
106 | ( $tradition->has_user && $tradition->user->id eq $user->id ) ); |
52dcc672 |
107 | return 1; |
75ce4f7a |
108 | } |
109 | # Is it public? |
110 | if( $tradition->public ) { |
52dcc672 |
111 | $c->stash->{'permission'} = 'readonly'; |
112 | return 1; |
75ce4f7a |
113 | } |
114 | # Forbidden! |
115 | $c->response->status( 403 ); |
116 | $c->response->body( 'You do not have permission to view this tradition.' ); |
117 | $c->detach( 'View::Plain' ); |
118 | return 0; |
52dcc672 |
119 | } |
120 | |
f8d13166 |
121 | =head2 graphsvg |
122 | |
123 | POST stexaminer/graphsvg |
124 | dot: <stemmagraph dot string> |
125 | layerwits: [ <a.c. witnesses ] |
126 | |
127 | Returns an SVG string of the given graph, extended to include the given |
128 | layered witnesses. |
129 | |
130 | =cut |
131 | |
132 | sub graphsvg :Local { |
133 | my( $self, $c ) = @_; |
134 | my $dot = $c->request->param('dot'); |
135 | my @layerwits = $c->request->param('layerwits[]'); |
136 | open my $stemma_fh, '<', \$dot; |
137 | binmode( $stemma_fh, ':encoding(UTF-8)' ); |
138 | my $emptycoll = Text::Tradition::Collation->new(); |
139 | my $tempstemma = Text::Tradition::Stemma->new( |
140 | collation => $emptycoll, 'dot' => $stemma_fh ); |
141 | my $svgopts = { size => [ 600, 350 ] }; |
142 | if( @layerwits ) { |
143 | $svgopts->{'layerwits'} = \@layerwits; |
144 | } |
145 | $c->stash->{'result'} = $tempstemma->as_svg( $svgopts ); |
146 | $c->forward('View::SVG'); |
147 | } |
148 | |
2376359f |
149 | =head2 end |
150 | |
151 | Attempt to render a view, if needed. |
152 | |
153 | =cut |
154 | |
155 | sub end : ActionClass('RenderView') {} |
156 | |
157 | =head1 AUTHOR |
158 | |
159 | Tara L Andrews |
160 | |
161 | =head1 LICENSE |
162 | |
163 | This library is free software. You can redistribute it and/or modify |
164 | it under the same terms as Perl itself. |
165 | |
166 | =cut |
167 | |
168 | __PACKAGE__->meta->make_immutable; |
169 | |
170 | 1; |