# Copyright 2008-2010 Tim Rayner
# 
# This file is part of Bio::MAGETAB.
# 
# Bio::MAGETAB is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
# 
# Bio::MAGETAB is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with Bio::MAGETAB.  If not, see <http://www.gnu.org/licenses/>.
#
# $Id: IDF.pm 340 2010-07-23 13:19:27Z tfrayner $

package Bio::MAGETAB::Util::Writer::IDF;

use Moose;
use MooseX::FollowPBP;

use Carp;
use List::Util qw( max );

BEGIN { extends 'Bio::MAGETAB::Util::Writer::Tabfile' };

has 'magetab_object'     => ( is         => 'ro',
                              isa        => 'Bio::MAGETAB::Investigation',
                              required   => 1 );

sub _collapse_contacts {

    my ( $self, @contacts ) = @_;

    # Given a list of Contact objects, collapse them into a list of
    # arrayrefs suitable for passing to $self->_write_line()

    # This is just a convenience hash to store data
    my %list = (
        'value'         => [ 'Person Roles' ],
        'termSource'    => [ 'Person Roles Term Source REF' ],
        'accession'     => [ 'Person Roles Term Accession Number' ],
    );
    foreach my $contact ( @contacts ) {

        # Multiple Role terms can be specified, separated by semicolons.
        push @{ $list{'value'} },
            ( join(';', map { $_->get_value() } $contact->get_roles() ) || q{} );

        # Unfortunately as of the v1.1 specification, multiple
        # TermSources and Accessions are a no-no. That makes this part
        # a bit more complicated than it needs to be.
        my (%ts_test, %acc_test, $ts1, $acc1);
        foreach my $role ( $contact->get_roles() ) {

            my $ts  = $role->get_termSource();
            my $acc = $role->get_accession();

            # Only store the first one of each.
            $ts1  ||= $ts;
            $acc1 ||= $acc;

            $ts_test{  $ts  } = $ts  if $ts;
            $acc_test{ $acc } = $acc if $acc;
        }

        # Warn where the model isn't quite in line with the spec.
        if ( ( scalar grep { defined $_ } values %ts_test ) > 1 ) {
            carp("Warning: Multiple Role Term Sources (unsupported by MAGE-TAB format).");
        }
        if ( ( scalar grep { defined $_ } values %acc_test ) > 1 ) {
            carp("Warning: Multiple Role Term Accessions (unsupported by MAGE-TAB format).");
        }

        # Just output the first TermSource and/or Accession we encountered.
        push @{ $list{'termSource'} }, ( $ts1 ? $ts1->get_name() : q{} );

        # Skip accessions for MAGE-TAB v1.0 export.
        if ( $self->get_export_version ne '1.0' ) {
            push @{ $list{'accession'} },  ( $acc1 || q{} );
        }
    }

    # This will be the eventual output order of the lines.
    return ( $list{'value'}, $list{'termSource'}, $list{'accession'} );
}

sub _get_thing_type {
    my ( $self, $thing ) = @_;
    my $type;
    if ( UNIVERSAL::can( $thing, 'get_type' ) ) {
        $type = $thing->get_type();
    }
    elsif ( UNIVERSAL::can( $thing, 'get_status' ) ) {
        $type = $thing->get_status();
    }
    elsif ( UNIVERSAL::can( $thing, 'get_factorType' ) ) {
        $type = $thing->get_factorType();
    }
    elsif ( UNIVERSAL::can( $thing, 'get_protocolType' ) ) {
        $type = $thing->get_protocolType();
    }
    else {
        confess("Error: Cannot find a ControlledVocab-linked attribute for "
                    . blessed $thing );
    }
    return $type;
}

sub _get_thing_type_value {
    my ( $self, $thing ) = @_;
    my $type = $self->_get_thing_type( $thing );
    return $type ? $type->get_value() : q{};
}

sub _get_thing_type_accession {
    my ( $self, $thing ) = @_;

    # Return undef if we're exporting MAGE-TAB v1.0.
    return if ( $self->get_export_version() eq '1.0' );

    my $type = $self->_get_thing_type( $thing );
    return $type ? $type->get_accession() : q{};
}

sub _get_thing_type_termsource_name {
    my ( $self, $thing ) = @_;
    my $type = $self->_get_thing_type( $thing );
    return $self->_get_type_termsource_name($type);
}

sub _get_thing_accession {
    my ( $self, $thing ) = @_;

    # Return undef if we're exporting MAGE-TAB v1.0.
    return if ( $self->get_export_version() eq '1.0' );

    return $thing->get_accession();    
}

sub write {

    my ( $self ) = @_;

    my $inv = $self->get_magetab_object();

    my %single = (
        'Investigation Title'    => 'title',
        'Experiment Description' => 'description',
        'Date of Experiment'     => 'date',
        'Public Release Date'    => 'publicReleaseDate',
    );

    # FIXME check these field names against the spec!
    my @other_comments;
    my %multi = (
        'contacts' => [
            sub { return ( [ 'Person Last Name',     map { $_->get_lastName()     } @_ ] ) },
            sub { return ( [ 'Person First Name',    map { $_->get_firstName()    } @_ ] ) },
            sub { return ( [ 'Person Mid Initials',  map { $_->get_midInitials()  } @_ ] ) },
            sub { return ( [ 'Person Email',         map { $_->get_email()        } @_ ] ) },
            sub { return ( [ 'Person Affiliation',   map { $_->get_organization() } @_ ] ) },
            sub { return ( [ 'Person Phone',         map { $_->get_phone()        } @_ ] ) },
            sub { return ( [ 'Person Fax',           map { $_->get_fax()          } @_ ] ) },
            sub { return ( [ 'Person Address',       map { $_->get_address()      } @_ ] ) },
            sub { $self->_collapse_contacts( @_ ); },
            sub { push @other_comments, map { $_->get_comments() } @_ },
        ],
        'factors' => [
            sub { return ( [ 'Experimental Factor Name', map { $_->get_name() } @_ ] ) },
            sub { return ( [ 'Experimental Factor Type',
                             map { $self->_get_thing_type_value($_) } @_ ] ) },
            sub { return ( [ 'Experimental Factor Term Source REF',
                             map { $self->_get_thing_type_termsource_name($_) } @_ ] ) },
            sub { return ( [ 'Experimental Factor Term Accession Number',
                             map { $self->_get_thing_type_accession($_) } @_ ] ) },
        ],
        'sdrfs' => [
            sub { return ( [ 'SDRF File', map { $_->get_uri()        } @_ ] ) },
        ],
        'protocols' => [
            sub { return ( [ 'Protocol Name',        map { $_->get_name()     } @_ ] ) },
            sub { return ( [ 'Protocol Description', map { $_->get_text()     } @_ ] ) },
            sub { return ( [ 'Protocol Software',    map { $_->get_software() } @_ ] ) },
            sub { return ( [ 'Protocol Hardware',    map { $_->get_hardware() } @_ ] ) },
            sub { return ( [ 'Protocol Contact',     map { $_->get_contact()  } @_ ] ) },
            sub { return ( [ 'Protocol Type',
                             map { $self->_get_thing_type_value($_) } @_ ] ) },
            sub { return ( [ 'Protocol Term Source REF',
                             map { $self->_get_thing_type_termsource_name($_) } @_ ] ) },
            sub { return ( [ 'Protocol Term Accession Number',
                             map { $self->_get_thing_type_accession($_) } @_ ] ) },
        ],
        'publications' => [
            sub { return ( [ 'Publication Title',       map { $_->get_title()      } @_ ] ) },
            sub { return ( [ 'Publication Author List', map { $_->get_authorList() } @_ ] ) },
            sub { return ( [ 'PubMed ID',               map { $_->get_pubMedID()   } @_ ] ) },
            sub { return ( [ 'Publication DOI',         map { $_->get_DOI()        } @_ ] ) },
            sub { return ( [ 'Publication Status',
                             map { $self->_get_thing_type_value($_) } @_ ] ) },
            sub { return ( [ 'Publication Status Term Source REF',
                             map { $self->_get_thing_type_termsource_name($_) } @_ ] ) },
            sub { return ( [ 'Publication Status Term Accession Number',
                             map { $self->_get_thing_type_accession($_) } @_ ] ) },
        ],
        'termSources' => [
            sub { return ( [ 'Term Source Name',       map { $_->get_name()    } @_ ] ) },
            sub { return ( [ 'Term Source Version',    map { $_->get_version() } @_ ] ) },
            sub { return ( [ 'Term Source File',       map { $_->get_uri()     } @_ ] ) },
        ],
        'designTypes' => [
            sub { return ( [ 'Experimental Design',
                             map { $_->get_value()     } @_ ] ) },
            sub { return ( [ 'Experimental Design Term Accession Number',
                             map { $self->_get_thing_accession($_) } @_ ] ) },
            sub { return ( [ 'Experimental Design Term Source REF',
                             map { $self->_get_type_termsource_name($_) } @_ ] ) },
        ],
        'normalizationTypes' => [
            sub { return ( [ 'Normalization Type',
                             map { $_->get_value()     } @_ ] ) },
            sub { return ( [ 'Normalization Term Accession Number',
                             map { $self->_get_thing_accession($_) } @_ ] ) },
            sub { return ( [ 'Normalization Term Source REF',
                             map { $self->_get_type_termsource_name($_) } @_ ] ) },
        ],
        'replicateTypes' => [
            sub { return ( [ 'Replicate Type',
                             map { $_->get_value()     } @_ ] ) },
            sub { return ( [ 'Replicate Term Accession Number',
                             map { $self->_get_thing_accession($_) } @_ ] ) },
            sub { return ( [ 'Replicate Term Source REF',
                             map { $self->_get_type_termsource_name($_) } @_ ] ) },
        ],
        'qualityControlTypes' => [
            sub { return ( [ 'Quality Control Type',
                             map { $_->get_value()     } @_ ] ) },
            sub { return ( [ 'Quality Control Term Accession Number',
                             map { $self->_get_thing_accession($_) } @_ ] ) },
            sub { return ( [ 'Quality Control Term Source REF',
                             map { $self->_get_type_termsource_name($_) } @_ ] ) },
        ],
    );

    # We want a regular table, so figure out how many columns we will
    # need. Note that we need a minimum of 2 columns to accommodate the single fields.
    my @objcounts = map {
        my $getter = "get_$_";
        scalar @{ [ $inv->$getter ] };
    } keys %multi;
    $self->set_num_columns( max( 1 + max @objcounts, 2 ) );

    # Introduce a Version tag (new in v1.1).
    unless ( $self->get_export_version() eq '1.0' ) {
        $self->_write_line( 'MAGE-TAB Version', '1.1' );
    }

    # Single elements are straightforward.
    while ( my ( $field, $value ) = each %single ) {
        my $getter = "get_$value";
        my $value  = $inv->$getter;
        if ( defined $value && $value ne q{} ) {
            $self->_write_line( $field, $value );
        }
    }

    # All the complicated stuff gets handled by the dispatch methods
    # in %multi.
    ATTR:
    while ( my ( $field, $subs ) = each %multi ) {
        my $getter = "get_$field";
        my @attrs = $inv->$getter;
        next ATTR if ( scalar @attrs == 1 && ! defined $attrs[0] );
        foreach my $sub ( @$subs ) {

            LINEREF:
            foreach my $lineref ( $sub->( @attrs ) ) {
                next LINEREF unless ref $lineref eq 'ARRAY';

                # Don't write the line if there's nothing to write but the tag.
                if ( scalar grep { defined $_ && $_ ne q{} } @{ $lineref }[1..$#$lineref] ) {
                    $self->_write_line( @{ $lineref } );
                }
            }
        }
    }

    # All comments on IDF-related classes are dumped into the IDF at
    # the end. FIXME consider maybe inserting them at the appropriate
    # places? Subsequent parsing won't preserve these locations though.
    foreach my $comment ( $inv->get_comments(), @other_comments ) {
        my $field = sprintf("Comment[%s]", $comment->get_name());
        $self->_write_line( $field, $comment->get_value() );
    }
}

# Make the classes immutable. In theory this speeds up object
# instantiation for a small compilation time cost.
__PACKAGE__->meta->make_immutable();

no Moose;

=head1 NAME

Bio::MAGETAB::Util::Writer::IDF - Export of MAGE-TAB Investigation
objects.

=head1 SYNOPSIS

 use Bio::MAGETAB::Util::Writer::IDF;
 my $writer = Bio::MAGETAB::Util::Writer::IDF->new({
    magetab_object => $investigation,
    filehandle     => $idf_fh,
 });
 
 $writer->write();

=head1 DESCRIPTION

Export of Investigations to IDF files.

=head1 ATTRIBUTES

See the L<Tabfile|Bio::MAGETAB::Util::Writer::Tabfile> class for superclass attributes.

=over 2

=item magetab_object

The Bio::MAGETAB::Investigation to export. This is a required
attribute.

=back

=head1 METHODS

=over 2

=item write

Exports the Investigation to IDF.

=back

=head1 SEE ALSO

L<Bio::MAGETAB::Util::Writer>
L<Bio::MAGETAB::Util::Writer::Tabfile>

=head1 AUTHOR

Tim F. Rayner <tfrayner@gmail.com>

=head1 LICENSE

This library is released under version 2 of the GNU General Public
License (GPL).

=cut

1;