1# Copyright 2008-2010 Tim Rayner 2# 3# This file is part of Bio::MAGETAB. 4# 5# Bio::MAGETAB is free software: you can redistribute it and/or modify 6# it under the terms of the GNU General Public License as published by 7# the Free Software Foundation, either version 2 of the License, or 8# (at your option) any later version. 9# 10# Bio::MAGETAB is distributed in the hope that it will be useful, 11# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# GNU General Public License for more details. 14# 15# You should have received a copy of the GNU General Public License 16# along with Bio::MAGETAB. If not, see <http://www.gnu.org/licenses/>. 17# 18# $Id: IDF.pm 340 2010-07-23 13:19:27Z tfrayner $ 19 20package Bio::MAGETAB::Util::Writer::IDF; 21 22use Moose; 23use MooseX::FollowPBP; 24 25use Carp; 26use List::Util qw( max ); 27 28BEGIN { extends 'Bio::MAGETAB::Util::Writer::Tabfile' }; 29 30has 'magetab_object' => ( is => 'ro', 31 isa => 'Bio::MAGETAB::Investigation', 32 required => 1 ); 33 34sub _collapse_contacts { 35 36 my ( $self, @contacts ) = @_; 37 38 # Given a list of Contact objects, collapse them into a list of 39 # arrayrefs suitable for passing to $self->_write_line() 40 41 # This is just a convenience hash to store data 42 my %list = ( 43 'value' => [ 'Person Roles' ], 44 'termSource' => [ 'Person Roles Term Source REF' ], 45 'accession' => [ 'Person Roles Term Accession Number' ], 46 ); 47 foreach my $contact ( @contacts ) { 48 49 # Multiple Role terms can be specified, separated by semicolons. 50 push @{ $list{'value'} }, 51 ( join(';', map { $_->get_value() } $contact->get_roles() ) || q{} ); 52 53 # Unfortunately as of the v1.1 specification, multiple 54 # TermSources and Accessions are a no-no. That makes this part 55 # a bit more complicated than it needs to be. 56 my (%ts_test, %acc_test, $ts1, $acc1); 57 foreach my $role ( $contact->get_roles() ) { 58 59 my $ts = $role->get_termSource(); 60 my $acc = $role->get_accession(); 61 62 # Only store the first one of each. 63 $ts1 ||= $ts; 64 $acc1 ||= $acc; 65 66 $ts_test{ $ts } = $ts if $ts; 67 $acc_test{ $acc } = $acc if $acc; 68 } 69 70 # Warn where the model isn't quite in line with the spec. 71 if ( ( scalar grep { defined $_ } values %ts_test ) > 1 ) { 72 carp("Warning: Multiple Role Term Sources (unsupported by MAGE-TAB format)."); 73 } 74 if ( ( scalar grep { defined $_ } values %acc_test ) > 1 ) { 75 carp("Warning: Multiple Role Term Accessions (unsupported by MAGE-TAB format)."); 76 } 77 78 # Just output the first TermSource and/or Accession we encountered. 79 push @{ $list{'termSource'} }, ( $ts1 ? $ts1->get_name() : q{} ); 80 81 # Skip accessions for MAGE-TAB v1.0 export. 82 if ( $self->get_export_version ne '1.0' ) { 83 push @{ $list{'accession'} }, ( $acc1 || q{} ); 84 } 85 } 86 87 # This will be the eventual output order of the lines. 88 return ( $list{'value'}, $list{'termSource'}, $list{'accession'} ); 89} 90 91sub _get_thing_type { 92 my ( $self, $thing ) = @_; 93 my $type; 94 if ( UNIVERSAL::can( $thing, 'get_type' ) ) { 95 $type = $thing->get_type(); 96 } 97 elsif ( UNIVERSAL::can( $thing, 'get_status' ) ) { 98 $type = $thing->get_status(); 99 } 100 elsif ( UNIVERSAL::can( $thing, 'get_factorType' ) ) { 101 $type = $thing->get_factorType(); 102 } 103 elsif ( UNIVERSAL::can( $thing, 'get_protocolType' ) ) { 104 $type = $thing->get_protocolType(); 105 } 106 else { 107 confess("Error: Cannot find a ControlledVocab-linked attribute for " 108 . blessed $thing ); 109 } 110 return $type; 111} 112 113sub _get_thing_type_value { 114 my ( $self, $thing ) = @_; 115 my $type = $self->_get_thing_type( $thing ); 116 return $type ? $type->get_value() : q{}; 117} 118 119sub _get_thing_type_accession { 120 my ( $self, $thing ) = @_; 121 122 # Return undef if we're exporting MAGE-TAB v1.0. 123 return if ( $self->get_export_version() eq '1.0' ); 124 125 my $type = $self->_get_thing_type( $thing ); 126 return $type ? $type->get_accession() : q{}; 127} 128 129sub _get_thing_type_termsource_name { 130 my ( $self, $thing ) = @_; 131 my $type = $self->_get_thing_type( $thing ); 132 return $self->_get_type_termsource_name($type); 133} 134 135sub _get_thing_accession { 136 my ( $self, $thing ) = @_; 137 138 # Return undef if we're exporting MAGE-TAB v1.0. 139 return if ( $self->get_export_version() eq '1.0' ); 140 141 return $thing->get_accession(); 142} 143 144sub write { 145 146 my ( $self ) = @_; 147 148 my $inv = $self->get_magetab_object(); 149 150 my %single = ( 151 'Investigation Title' => 'title', 152 'Experiment Description' => 'description', 153 'Date of Experiment' => 'date', 154 'Public Release Date' => 'publicReleaseDate', 155 ); 156 157 # FIXME check these field names against the spec! 158 my @other_comments; 159 my %multi = ( 160 'contacts' => [ 161 sub { return ( [ 'Person Last Name', map { $_->get_lastName() } @_ ] ) }, 162 sub { return ( [ 'Person First Name', map { $_->get_firstName() } @_ ] ) }, 163 sub { return ( [ 'Person Mid Initials', map { $_->get_midInitials() } @_ ] ) }, 164 sub { return ( [ 'Person Email', map { $_->get_email() } @_ ] ) }, 165 sub { return ( [ 'Person Affiliation', map { $_->get_organization() } @_ ] ) }, 166 sub { return ( [ 'Person Phone', map { $_->get_phone() } @_ ] ) }, 167 sub { return ( [ 'Person Fax', map { $_->get_fax() } @_ ] ) }, 168 sub { return ( [ 'Person Address', map { $_->get_address() } @_ ] ) }, 169 sub { $self->_collapse_contacts( @_ ); }, 170 sub { push @other_comments, map { $_->get_comments() } @_ }, 171 ], 172 'factors' => [ 173 sub { return ( [ 'Experimental Factor Name', map { $_->get_name() } @_ ] ) }, 174 sub { return ( [ 'Experimental Factor Type', 175 map { $self->_get_thing_type_value($_) } @_ ] ) }, 176 sub { return ( [ 'Experimental Factor Term Source REF', 177 map { $self->_get_thing_type_termsource_name($_) } @_ ] ) }, 178 sub { return ( [ 'Experimental Factor Term Accession Number', 179 map { $self->_get_thing_type_accession($_) } @_ ] ) }, 180 ], 181 'sdrfs' => [ 182 sub { return ( [ 'SDRF File', map { $_->get_uri() } @_ ] ) }, 183 ], 184 'protocols' => [ 185 sub { return ( [ 'Protocol Name', map { $_->get_name() } @_ ] ) }, 186 sub { return ( [ 'Protocol Description', map { $_->get_text() } @_ ] ) }, 187 sub { return ( [ 'Protocol Software', map { $_->get_software() } @_ ] ) }, 188 sub { return ( [ 'Protocol Hardware', map { $_->get_hardware() } @_ ] ) }, 189 sub { return ( [ 'Protocol Contact', map { $_->get_contact() } @_ ] ) }, 190 sub { return ( [ 'Protocol Type', 191 map { $self->_get_thing_type_value($_) } @_ ] ) }, 192 sub { return ( [ 'Protocol Term Source REF', 193 map { $self->_get_thing_type_termsource_name($_) } @_ ] ) }, 194 sub { return ( [ 'Protocol Term Accession Number', 195 map { $self->_get_thing_type_accession($_) } @_ ] ) }, 196 ], 197 'publications' => [ 198 sub { return ( [ 'Publication Title', map { $_->get_title() } @_ ] ) }, 199 sub { return ( [ 'Publication Author List', map { $_->get_authorList() } @_ ] ) }, 200 sub { return ( [ 'PubMed ID', map { $_->get_pubMedID() } @_ ] ) }, 201 sub { return ( [ 'Publication DOI', map { $_->get_DOI() } @_ ] ) }, 202 sub { return ( [ 'Publication Status', 203 map { $self->_get_thing_type_value($_) } @_ ] ) }, 204 sub { return ( [ 'Publication Status Term Source REF', 205 map { $self->_get_thing_type_termsource_name($_) } @_ ] ) }, 206 sub { return ( [ 'Publication Status Term Accession Number', 207 map { $self->_get_thing_type_accession($_) } @_ ] ) }, 208 ], 209 'termSources' => [ 210 sub { return ( [ 'Term Source Name', map { $_->get_name() } @_ ] ) }, 211 sub { return ( [ 'Term Source Version', map { $_->get_version() } @_ ] ) }, 212 sub { return ( [ 'Term Source File', map { $_->get_uri() } @_ ] ) }, 213 ], 214 'designTypes' => [ 215 sub { return ( [ 'Experimental Design', 216 map { $_->get_value() } @_ ] ) }, 217 sub { return ( [ 'Experimental Design Term Accession Number', 218 map { $self->_get_thing_accession($_) } @_ ] ) }, 219 sub { return ( [ 'Experimental Design Term Source REF', 220 map { $self->_get_type_termsource_name($_) } @_ ] ) }, 221 ], 222 'normalizationTypes' => [ 223 sub { return ( [ 'Normalization Type', 224 map { $_->get_value() } @_ ] ) }, 225 sub { return ( [ 'Normalization Term Accession Number', 226 map { $self->_get_thing_accession($_) } @_ ] ) }, 227 sub { return ( [ 'Normalization Term Source REF', 228 map { $self->_get_type_termsource_name($_) } @_ ] ) }, 229 ], 230 'replicateTypes' => [ 231 sub { return ( [ 'Replicate Type', 232 map { $_->get_value() } @_ ] ) }, 233 sub { return ( [ 'Replicate Term Accession Number', 234 map { $self->_get_thing_accession($_) } @_ ] ) }, 235 sub { return ( [ 'Replicate Term Source REF', 236 map { $self->_get_type_termsource_name($_) } @_ ] ) }, 237 ], 238 'qualityControlTypes' => [ 239 sub { return ( [ 'Quality Control Type', 240 map { $_->get_value() } @_ ] ) }, 241 sub { return ( [ 'Quality Control Term Accession Number', 242 map { $self->_get_thing_accession($_) } @_ ] ) }, 243 sub { return ( [ 'Quality Control Term Source REF', 244 map { $self->_get_type_termsource_name($_) } @_ ] ) }, 245 ], 246 ); 247 248 # We want a regular table, so figure out how many columns we will 249 # need. Note that we need a minimum of 2 columns to accommodate the single fields. 250 my @objcounts = map { 251 my $getter = "get_$_"; 252 scalar @{ [ $inv->$getter ] }; 253 } keys %multi; 254 $self->set_num_columns( max( 1 + max @objcounts, 2 ) ); 255 256 # Introduce a Version tag (new in v1.1). 257 unless ( $self->get_export_version() eq '1.0' ) { 258 $self->_write_line( 'MAGE-TAB Version', '1.1' ); 259 } 260 261 # Single elements are straightforward. 262 while ( my ( $field, $value ) = each %single ) { 263 my $getter = "get_$value"; 264 my $value = $inv->$getter; 265 if ( defined $value && $value ne q{} ) { 266 $self->_write_line( $field, $value ); 267 } 268 } 269 270 # All the complicated stuff gets handled by the dispatch methods 271 # in %multi. 272 ATTR: 273 while ( my ( $field, $subs ) = each %multi ) { 274 my $getter = "get_$field"; 275 my @attrs = $inv->$getter; 276 next ATTR if ( scalar @attrs == 1 && ! defined $attrs[0] ); 277 foreach my $sub ( @$subs ) { 278 279 LINEREF: 280 foreach my $lineref ( $sub->( @attrs ) ) { 281 next LINEREF unless ref $lineref eq 'ARRAY'; 282 283 # Don't write the line if there's nothing to write but the tag. 284 if ( scalar grep { defined $_ && $_ ne q{} } @{ $lineref }[1..$#$lineref] ) { 285 $self->_write_line( @{ $lineref } ); 286 } 287 } 288 } 289 } 290 291 # All comments on IDF-related classes are dumped into the IDF at 292 # the end. FIXME consider maybe inserting them at the appropriate 293 # places? Subsequent parsing won't preserve these locations though. 294 foreach my $comment ( $inv->get_comments(), @other_comments ) { 295 my $field = sprintf("Comment[%s]", $comment->get_name()); 296 $self->_write_line( $field, $comment->get_value() ); 297 } 298} 299 300# Make the classes immutable. In theory this speeds up object 301# instantiation for a small compilation time cost. 302__PACKAGE__->meta->make_immutable(); 303 304no Moose; 305 306=head1 NAME 307 308Bio::MAGETAB::Util::Writer::IDF - Export of MAGE-TAB Investigation 309objects. 310 311=head1 SYNOPSIS 312 313 use Bio::MAGETAB::Util::Writer::IDF; 314 my $writer = Bio::MAGETAB::Util::Writer::IDF->new({ 315 magetab_object => $investigation, 316 filehandle => $idf_fh, 317 }); 318 319 $writer->write(); 320 321=head1 DESCRIPTION 322 323Export of Investigations to IDF files. 324 325=head1 ATTRIBUTES 326 327See the L<Tabfile|Bio::MAGETAB::Util::Writer::Tabfile> class for superclass attributes. 328 329=over 2 330 331=item magetab_object 332 333The Bio::MAGETAB::Investigation to export. This is a required 334attribute. 335 336=back 337 338=head1 METHODS 339 340=over 2 341 342=item write 343 344Exports the Investigation to IDF. 345 346=back 347 348=head1 SEE ALSO 349 350L<Bio::MAGETAB::Util::Writer> 351L<Bio::MAGETAB::Util::Writer::Tabfile> 352 353=head1 AUTHOR 354 355Tim F. Rayner <tfrayner@gmail.com> 356 357=head1 LICENSE 358 359This library is released under version 2 of the GNU General Public 360License (GPL). 361 362=cut 363 3641; 365