1package Bio::Das::Request::Features; 2# $Id: Features.pm,v 1.16 2010/06/16 21:28:41 lstein Exp $ 3# this module issues and parses the types command, with arguments -dsn, -segment, -categories, -enumerate 4 5use strict; 6use Bio::Das::Type; 7use Bio::Das::Feature; 8use Bio::Das::Segment; 9use Bio::Das::Request; 10use Bio::Das::Util 'rearrange'; 11 12use vars '@ISA'; 13@ISA = 'Bio::Das::Request'; 14 15sub new { 16 my $pack = shift; 17 my ($dsn,$segments,$types,$categories,$feature_id,$group_id,$das,$fcallback,$scallback) 18 = rearrange([ 19 ['dsn','dsns'], 20 ['segment','segments'], 21 ['type','types'], 22 ['category','categories'], 23 'feature_id', 24 'group_id', 25 'das', 26 ['callback','feature_callback'], 27 'segment_callback', 28 ],@_); 29 my $self = $pack->SUPER::new( 30 -dsn => $dsn, 31 -callback => $fcallback, 32 -args => { 33 segment => $segments, 34 category => $categories, 35 type => $types, 36 feature_id => $feature_id, 37 group_id => $group_id, 38 } 39 ); 40 $self->{segment_callback} = $scallback if $scallback; 41 $self->das($das) if defined $das; 42 $self; 43} 44 45sub command { 'features' } 46 47sub das { 48 my $self = shift; 49 my $d = $self->{das}; 50 $self->{das} = shift if @_; 51 $d; 52} 53 54sub segment_callback { shift->{segment_callback} } 55 56sub t_DASGFF { 57 my $self = shift; 58 my $attrs = shift; 59 if ($attrs) { 60 $self->clear_results; 61 } 62 delete $self->{tmp}; 63} 64 65sub t_GFF { 66 # nothing to do here -- probably should check version 67} 68 69sub t_SEGMENT { 70 my $self = shift; 71 my $attrs = shift; 72 if ($attrs) { # segment section is starting 73 $self->{tmp}{current_segment} = Bio::Das::Segment->new($attrs->{id},$attrs->{start}, 74 $attrs->{stop},$attrs->{version}, 75 $self->das,$self->dsn 76 ); 77 $self->{tmp}{current_feature} = undef; 78 $self->{tmp}{features} = []; 79 } 80 81 else { # reached the end of the segment, so push result 82 $self->finish_segment(); 83 } 84 85} 86 87sub finish_segment { 88 my $self = shift; 89 90 $self->infer_parents_from_groups($self->{tmp}{features}); 91 my $features = $self->build_object_hierarchy($self->{tmp}{features}); 92 93 if ($self->segment_callback) { 94 eval {$self->segment_callback->($self->{tmp}{current_segment}=>$features)}; 95 warn $@ if $@; 96 } else { 97 $self->add_object($self->{tmp}{current_segment},$features); 98 } 99 delete $self->{tmp}{current_segment}; 100 delete $self->{tmp}{features}; 101} 102 103# for features that have a <group> but no parent or parts, 104# create inferred parents 105sub infer_parents_from_groups { 106 my $self = shift; 107 my $f = shift; 108 109 my (%inferred_parents,%group_types); 110 for my $feature (@$f) { 111 112 my $group = $feature->group or next; 113 next if $feature->parent_id; 114 next if $feature->child_ids > 0; 115 116 $group = "group_$group"; # avoid collisions 117 118 unless ($inferred_parents{$group}) { 119 my $p = $inferred_parents{$group} = Bio::Das::Feature->new( 120 -segment => $feature->segment, 121 -id => $group, 122 -start => $feature->start, 123 -stop => $feature->stop 124 ); 125 $p->orientation($feature->orientation); 126 $p->category('group'); 127 my $gt = $feature->group_type || $feature->type; 128 my $type = $group_types{$gt} 129 ||= Bio::Das::Type->new($gt,$gt,'group'); 130 $p->type($type); 131 $p->link($feature->link); 132 $p->label($feature->label); 133 } 134 135 my $p = $inferred_parents{$group}; 136 $p->start($feature->start) if $feature->start < $p->start; 137 $p->stop($feature->stop) if $feature->stop > $p->stop; 138 $feature->parent_id($group); 139 $p->add_child_id($feature->id); 140 } 141 push @$f,values %inferred_parents; 142} 143 144 145# this builds up hierarchical objects using their parent/child relationships 146sub build_object_hierarchy { 147 my $self = shift; 148 my $f = shift; 149 my %id_to_feature = map {$_->id => $_} @$f; 150 151 my @top_level; 152 for my $feature (@$f) { 153 my $parent_id = $feature->parent_id; 154 if (defined $parent_id 155 && (my $parent = $id_to_feature{$parent_id})) { 156 $parent->add_subfeature($feature); 157 } else { 158 push @top_level,$feature; 159 } 160 } 161 return \@top_level; 162} 163 164sub cleanup { 165 my $self = shift; 166 # this fixes a problem in the UCSC server 167 $self->finish_segment if $self->{tmp}{current_segment}; 168} 169 170sub add_object { 171 my $self = shift; 172 push @{$self->{results}},@_; 173} 174 175 176# do nothing 177sub t_UNKNOWNSEGMENT { } 178sub t_ERRORSEGMENT { } 179 180sub t_FEATURE { 181 my $self = shift; 182 my $attrs = shift; 183 184 if ($attrs) { # start of tag 185 my $feature = $self->{tmp}{current_feature} = Bio::Das::Feature->new($self->{tmp}{current_segment}, 186 $attrs->{id} 187 ); 188 $feature->label($attrs->{label}) if exists $attrs->{label}; 189 $self->{tmp}{type} = undef; 190 } 191 192 else { 193 # feature is ending. This would be the place to do group aggregation 194 my $feature = $self->{tmp}{current_feature}; 195 my $cft = $feature->type; 196 197 if (!$cft->complete) { 198 # fix up broken das servers that don't set a method 199 # the id and method will be set to the same value 200 $cft->id($cft->method) if $cft->method && !$cft->id; 201 $cft->method($cft->id) if $cft->id && !$cft->method; 202 } 203 204 if (my $callback = $self->callback) { 205 $callback->($feature); 206 } else { 207 push @{$self->{tmp}{features}},$feature; 208 } 209 } 210} 211 212sub t_TYPE { 213 my $self = shift; 214 my $attrs = shift; 215 my $feature = $self->{tmp}{current_feature} or return; 216 217 my $cft = $self->{tmp}{type} ||= Bio::Das::Type->new(); 218 219 if ($attrs) { # tag starts 220 $cft->id($attrs->{id}); 221 $cft->category($attrs->{category}) if $attrs->{category}; 222 $cft->reference(1) if $attrs->{reference} && $attrs->{reference} eq 'yes'; 223 $cft->has_subparts(1) if $attrs->{subparts} && $attrs->{subparts} eq 'yes'; 224 $cft->has_superparts(1) if $attrs->{superparts} && $attrs->{superparts} eq 'yes'; 225 } else { 226 227 # possibly add a label 228 if (my $label = $self->char_data) { 229 $cft->label($label); 230 } 231 232 my $type = $self->_cache_types($cft); 233 $feature->type($type); 234 } 235} 236 237sub t_METHOD { 238 my $self = shift; 239 my $attrs = shift; 240 my $feature = $self->{tmp}{current_feature} or return; 241 my $cft = $self->{tmp}{type} ||= Bio::Das::Type->new(); 242 243 if ($attrs) { # tag starts 244 $cft->method($attrs->{id}); 245 } 246 247 else { # tag ends 248 249 # possibly add a label 250 if (my $label = $self->char_data) { 251 $cft->method_label($label); 252 } 253 254 if ($cft->complete) { 255 my $type = $self->_cache_types($cft); 256 $feature->type($type); 257 } 258 259 } 260} 261 262sub t_PARENT { 263 my $self = shift; 264 my $attrs = shift; 265 my $feature = $self->{tmp}{current_feature} or return; 266 $feature->parent_id($attrs->{id}) if $attrs; 267} 268 269sub t_PART { 270 my $self = shift; 271 my $attrs = shift; 272 my $feature = $self->{tmp}{current_feature} or return; 273 $feature->add_child_id($attrs->{id}) if $attrs; 274} 275 276sub t_START { 277 my $self = shift; 278 my $attrs = shift; 279 my $feature = $self->{tmp}{current_feature} or return; 280 $feature->start($self->char_data) unless $attrs; 281} 282 283sub t_END { 284 my $self = shift; 285 my $attrs = shift; 286 my $feature = $self->{tmp}{current_feature} or return; 287 $feature->stop($self->char_data) unless $attrs; 288} 289 290sub t_SCORE { 291 my $self = shift; 292 my $attrs = shift; 293 my $feature = $self->{tmp}{current_feature} or return; 294 $feature->score($self->char_data) unless $attrs; 295} 296 297sub t_ORIENTATION { 298 my $self = shift; 299 my $attrs = shift; 300 my $feature = $self->{tmp}{current_feature} or return; 301 $feature->orientation($self->char_data) unless $attrs; 302} 303 304sub t_PHASE { 305 my $self = shift; 306 my $attrs = shift; 307 my $feature = $self->{tmp}{current_feature} or return; 308 $feature->phase($self->char_data) unless $attrs; 309} 310 311sub t_GROUP { 312 my $self = shift; 313 my $attrs = shift; 314 my $feature = $self->{tmp}{current_feature} or return; 315 if($attrs) { 316 $feature->group_label( $attrs->{label} ); 317 $feature->group_type( $attrs->{type} ); 318 $feature->group( $attrs->{id} ); 319 } 320} 321 322sub t_LINK { 323 my $self = shift; 324 my $attrs = shift; 325 my $feature = $self->{tmp}{current_feature} or return; 326 if($attrs) { 327 $feature->link( $attrs->{href} ); 328 } else { 329 $feature->link_label( $self->char_data ); 330 } 331} 332 333sub t_NOTE { 334 my $self = shift; 335 my $attrs = shift; 336 my $feature = $self->{tmp}{current_feature} or return; 337 if ($attrs) { 338 $self->{tmp}{note_tag} = $attrs->{tag} if exists $attrs->{tag}; 339 } else { 340 $feature->add_note($self->{tmp}{note_tag},$self->char_data); 341 } 342} 343 344sub t_TARGET { 345 my $self = shift; 346 my $attrs = shift; 347 my $feature = $self->{tmp}{current_feature} or return; 348 if($attrs){ 349 $feature->target($attrs->{id},$attrs->{start},$attrs->{stop}); 350 } else { 351 $feature->target_label($self->char_data()); 352 } 353} 354 355sub _cache_types { 356 my $self = shift; 357 my $type = shift; 358 my $key = $type->_key; 359 return $self->{cached_types}{$key} ||= $type; 360} 361 362# override for segmentation behavior 363sub results { 364 my $self = shift; 365 my %r = $self->SUPER::results or return; 366 367 # in array context, return the list of types 368 return map { @{$_} } values %r if wantarray; 369 370 # otherwise return ref to a hash 371 return \%r; 372} 373 374 3751; 376