File Coverage

blib/lib/Chemistry/OpenSMILES/Aromaticity.pm
Criterion Covered Total %
statement 91 93 97.8
branch 17 26 65.3
condition 16 21 76.1
subroutine 17 17 100.0
pod 3 3 100.0
total 144 160 90.0


line stmt bran cond sub pod time code
1             package Chemistry::OpenSMILES::Aromaticity;
2              
3 1     1   521 use strict;
  1         2  
  1         30  
4 1     1   5 use warnings;
  1         2  
  1         44  
5              
6             # ABSTRACT: Aromaticity handling routines
7             our $VERSION = '0.8.4'; # VERSION
8              
9 1         53 use Chemistry::OpenSMILES qw(
10             is_aromatic
11             is_double_bond
12             is_single_bond
13 1     1   6 );
  1         3  
14 1     1   444 use Graph::Traversal::DFS;
  1         284  
  1         31  
15 1     1   7 use List::Util qw( all );
  1         29  
  1         1263  
16              
17             =head1 NAME
18              
19             Chemistry::OpenSMILES::Aromaticity - Aromaticity handling routines
20              
21             =head1 DESCRIPTION
22              
23             Chemistry::OpenSMILES::Aromaticity encodes some aromaticity handling
24             subroutines for aromatisation and kekulisation. Both implementations are
25             experimental, handle only some specific cases and are neither stable nor
26             bug-free, thus should be used with caution.
27              
28             =cut
29              
30             require Exporter;
31             our @ISA = qw( Exporter );
32             our @EXPORT_OK = qw(
33             aromatise
34             electron_cycles
35             kekulise
36             );
37              
38             =head1 METHODS
39              
40             =over 4
41              
42             =item aromatise( $moiety )
43              
44             Mark electron cycles as aromatic.
45              
46             =cut
47              
48             sub aromatise
49             {
50 1     1 1 7 my( $moiety ) = @_;
51              
52 1         5 my @electron_cycles = electron_cycles( $moiety );
53 1         4 for my $cycle (@electron_cycles) {
54 1         5 for my $i (0..$#$cycle) {
55             # Set bond to aromatic
56 6         29 $moiety->set_edge_attribute( $cycle->[$i],
57             $cycle->[($i + 1) % scalar @$cycle],
58             'bond',
59             ':' );
60             # Set atom to aromatic
61 6 50       1316 if( $cycle->[$i]{symbol} =~ /^([BCNOPS]|Se|As)$/ ) {
62 6         30 $cycle->[$i]{symbol} = lcfirst $cycle->[$i]{symbol};
63             }
64             }
65             }
66             }
67              
68             =item kekulise( $moiety )
69              
70             Find nonfused even-length aromatic cycles consisting only of B, C, N, P, S
71             and mark them with aliterating single and double bonds.
72              
73             =cut
74              
75             sub kekulise
76             {
77 1     1 1 882 my( $moiety ) = @_;
78              
79 1         12 my $aromatic_only = $moiety->copy_graph;
80 1         3313 $aromatic_only->delete_vertices( grep { !is_aromatic $_ }
  12         48  
81             $aromatic_only->vertices );
82              
83 1         1429 my @components;
84             my $get_root = sub {
85 2     2   991 my( $self, $unseen ) = @_;
86 2         10 my( $next ) = sort { $unseen->{$a}{number} <=> $unseen->{$b}{number} }
  11         24  
87             keys %$unseen;
88 2 100       11 return unless defined $next;
89              
90 1         3 push @components, [];
91 1         4 return $unseen->{$next};
92 1         6 };
93              
94             my $operations = {
95             first_root => $get_root,
96             next_root => $get_root,
97 6     6   1707 pre => sub { push @{$components[-1]}, $_[0] },
  6         19  
98 1         7 };
99 1         6 my $traversal = Graph::Traversal::DFS->new( $aromatic_only, %$operations );
100 1         300 $traversal->dfs;
101              
102 1         9 for my $component (@components) {
103             # Taking only simple even-length cycles into consideration
104 1 50   6   8 next unless all { $aromatic_only->degree( $_ ) == 2 } @$component;
  6         2200  
105 1 50   6   489 next unless all { $moiety->degree( $_ ) <= 3 } @$component;
  6         2549  
106 1 50   6   514 next unless all { $_->{symbol} =~ /^[BCNPS]$/i } @$component;
  6         18  
107 1 50       6 next if @$component % 2;
108              
109 1         6 my( $first ) = sort { $a->{number} <=> $b->{number} } @$component;
  9         19  
110 1         15 my( $second ) = sort { $a->{number} <=> $b->{number} }
  1         109  
111             $aromatic_only->neighbours( $first );
112 1         3 my $n = 0;
113 1         5 while( $n < @$component ) {
114 6         19 $first->{symbol} = ucfirst $first->{symbol};
115 6 100       19 if( $n % 2 ) {
116 3         10 $moiety->set_edge_attribute( $first, $second, 'bond', '=' );
117             } else {
118 3         14 $moiety->delete_edge_attribute( $first, $second, 'bond' );
119             }
120             ( $first, $second ) =
121 6         1339 ( $second, grep { $_ ne $first } $aromatic_only->neighbours( $second ) );
  12         658  
122 6         53 $n++;
123             }
124             }
125             }
126              
127             =item electron_cycles( $moiety )
128              
129             Find electron cycles according to "Finding Electron Cycles" algorithm from
130             L.
131             Use with caution: the implementation is experimental.
132              
133             =cut
134              
135             sub electron_cycles
136             {
137 1     1 1 2 my( $moiety ) = @_;
138              
139 1         2 my @cycles;
140 1         4 for my $start ($moiety->vertices) {
141 12         2125 my %seen;
142             my %prev;
143             my $operations = {
144 12     12   499 start => sub { return $start },
145 144     144   5081 pre => sub { $seen{$_[0]} = 1 },
146             pre_edge => sub {
147 132     132   62695 my( $u, $v ) = @_;
148 132 50       389 ( $u, $v ) = ( $v, $u ) if $seen{$v};
149 132         352 $prev{$v} = $u;
150             },
151             non_tree_edge => sub {
152 24     24   16429 my( $u, $v ) = @_;
153 24 100 100     171 if( $u == $start || $v == $start ) {
154 12 100       35 ( $u, $v ) = ( $v, $u ) if $v == $start;
155 12         26 my $current = $v;
156 12         20 my $prev_bond_is_single;
157 12         20 my $cycle_is_alterating = 1;
158 12         29 my @cycle = ( $u );
159 12         37 while( $prev{$current} ) {
160 60 50 66     351 if( ( !defined $prev_bond_is_single && (
      100        
      66        
      100        
      33        
      66        
161             is_single_bond( $moiety, $current, $prev{$current} ) ||
162             is_double_bond( $moiety, $current, $prev{$current} ) ) ) ||
163             ( $prev_bond_is_single && is_double_bond( $moiety, $current, $prev{$current} ) ) ||
164             ( !$prev_bond_is_single && is_single_bond( $moiety, $current, $prev{$current} ) ) ) {
165             # Logic is inverted here as $prev_bond_is_single is
166             # inverted after the conditional.
167 60         18775 $prev_bond_is_single = !is_single_bond( $moiety, $current, $prev{$current} );
168 60         18281 push @cycle, $current;
169 60         146 $current = $prev{$current};
170             } else {
171 0         0 $cycle_is_alterating = 0;
172 0         0 last;
173             }
174 60 50       129 last unless $cycle_is_alterating;
175 60         171 $prev_bond_is_single = 1 - $prev_bond_is_single;
176             }
177 12 50       50 push @cycles, \@cycle if $cycle_is_alterating;
178             }
179             },
180 12         118 };
181              
182 12         97 my $traversal = Graph::Traversal::DFS->new( $moiety, %$operations );
183 12         3872 $traversal->dfs;
184             }
185              
186 1         351 my %unique;
187 1         4 for (@cycles) {
188 12         74 $unique{join '', sort @$_} = $_;
189             }
190 1         9 return values %unique;
191             }
192              
193             =back
194              
195             =cut
196              
197             1;