File Coverage

blib/lib/Text/CSV/R.pm

Criterion	Covered	Total	%
statement	185	185	100.0
branch	71	76	93.4
condition	38	42	90.4
subroutine	26	26	100.0
pod	8	8	100.0
total	328	337	97.3

package Text::CSV::R;

require 5.005;

use strict;
use warnings;

require Exporter;
use Text::CSV;
use Text::CSV::R::Matrix;
use Carp;
use Scalar::Util qw(reftype looks_like_number openhandle);
use List::Util qw(min max);

our @ISA = qw(Exporter);

our %EXPORT_TAGS = (
    'all' => [
        qw(read_csv read_csv2 read_table read_delim write_table write_csv rownames colnames)
    ]
);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our $VERSION = '0.3';

# A mapping of the R options to the Text:CSV options. False if there is no
# Text::CSV equivalent (specified because R options are not passed to
# Text::CSV, so we need to know all of them).
our $R_OPT_MAP = {
    sep         => 'sep_char',
    strip_white => 'allow_whitespace',
    quote       => 'quote_char',
    map { $_ => 0 }
        qw(dec skip nrow header encoding row_names col_names
        blank_lines_skip append hr fill),
};

# merge the global default options, function defaults and user options
sub _merge_options {
    my ( $t_opt, $u_opt ) = @_;
    my %ret = (
        skip             => 0,
        nrow             => -1,
        sep_char         => "\t",
        binary           => 1,
        blank_lines_skip => 1,
    );
    @ret{ keys %{$t_opt} } = values %{$t_opt};
    @ret{ keys %{$u_opt} } = values %{$u_opt};
    for my $k ( keys %{$R_OPT_MAP} ) {
        if ( defined $ret{$k} && $R_OPT_MAP->{$k} ) {
            $ret{ $R_OPT_MAP->{$k} } = $ret{$k};
        }
    }
    return \%ret;
}

sub read_table {
    my ( $file, %u_opt ) = @_;
    return _read( $file, _merge_options( {}, \%u_opt ) );
}

sub read_csv {
    my ( $file, %u_opt ) = @_;
    my $t_opt = { sep_char => q{,}, header => 1, };
    return _read( $file, _merge_options( $t_opt, \%u_opt ) );
}

sub read_csv2 {
    my ( $file, %u_opt ) = @_;
    my $t_opt = { sep_char => q{;}, dec => q{,}, header => 1, };
    return _read( $file, _merge_options( $t_opt, \%u_opt ) );
}

sub read_delim {
    my ( $file, %u_opt ) = @_;
    my $t_opt = { sep_char => "\t", header => 1, };
    return _read( $file, _merge_options( $t_opt, \%u_opt ) );
}

sub write_table {
    my ( $data_ref, $file, %u_opt ) = @_;
    return _write( $data_ref, $file,
        _merge_options( { eol => "\n", fill => 1 }, \%u_opt ) );
}

sub write_csv {
    my ( $data_ref, $file, %u_opt ) = @_;
    my $t_opt = { eol => "\n", fill => 1, hr => 1, sep_char => q{,} };
    return _write( $data_ref, $file, _merge_options( $t_opt, \%u_opt ) );
}

sub rownames {
    my ( $tied_ref, $values ) = @_;
    return Text::CSV::R::Matrix::ROWNAMES( tied @{$tied_ref}, $values );
}

sub colnames {
    my ( $tied_ref, $values ) = @_;
    return Text::CSV::R::Matrix::COLNAMES( tied @{$tied_ref}, $values );
}

# check if $file is an open filehandle, if not open file with correct
# encoding.  return also whether to close the filehandle or not
sub _get_fh {
    my ( $file, $read, $opts ) = @_;
    if ( openhandle($file) ) {
        return ( $file, 0 );
    }
    my $encoding = q{};
    if ( defined $opts->{encoding} && length $opts->{encoding} > 0 ) {
        $encoding = ':encoding(' . $opts->{encoding} . ')';
    }
    my $mode
        = $read ? '<'
        : ( defined $opts->{append} && $opts->{append} ) ? '>>'
        :                                                  '>';
    open my $IN, $mode . $encoding, $file
        or croak "Cannot open $file for reading: $!";
    return ( $IN, 1 );
}

# replace decimal point if necessary
sub _replace_dec {
    my ( $data_ref, $opts, $read ) = @_;
    if ( defined $opts->{dec} && $opts->{dec} ne q{.} ) {
        for my $row ( @{$data_ref} ) {
            $row = [ map { _replace_dec_col( $_, $opts, $read ) } @{$row} ];
        }
    }
    return;
}

sub _replace_dec_col {
    my ( $col, $opts, $read ) = @_;
    if ($read) {
        ( my $tmp = $col ) =~ s{$opts->{dec}}{.}xms;
        $col = looks_like_number($tmp) ? $tmp : $col;
    }
    elsif ( looks_like_number($col) ) {
        $col =~ s{\.}{$opts->{dec}}xms;
    }
    return $col;
}

sub _fill {
    my ($data) = @_;
    my @l = map { scalar @{$_} } @{$data};
    my $max = max @l;
    if ($max == min @l) { return; }
    for my $row_id ( 0 .. $#l ) {
        for my $i ( 1 .. ( $max - $l[$row_id] ) ) {
            push @{ $data->[$row_id] }, q{};
        }
    }
    return;
}

sub _read {
    my ( $file, $opts ) = @_;

    my ( $fh, $toclose ) = _get_fh( $file, 1, $opts );
    my $data_ref = _parse_fh( $fh, $opts );
    if ($toclose) {
        close $fh or croak "Cannot close $file: $!";
    }
    _replace_dec( $data_ref, $opts, 1 );

    if ( defined $opts->{fill} && $opts->{fill} ) {
        _fill($data_ref);
    }

    return $data_ref;
}

sub _write {
    my ( $data_ref, $file, $opts ) = @_;

    my ( $fh, $toclose ) = _get_fh( $file, 0, $opts );
    _replace_dec( $data_ref, $opts, 0 );
    if ( defined $opts->{fill} && $opts->{fill} ) {
        _fill($data_ref);
    }
    _write_to_fh( $data_ref, $fh, $opts );
    if ($toclose) {
        close $fh or croak "Cannot close $file: $!";
    }
    return;
}

sub _create_csv_obj {
    my %text_csv_opts = @_;
    delete @text_csv_opts{ keys %{$R_OPT_MAP} };
    my $csv = Text::CSV->new( \%text_csv_opts )
        or croak q{Cannot use CSV: } . Text::CSV->error_diag();
    return $csv;
}

sub _write_to_fh {
    my ( $data_ref, $IN, $opts ) = @_;

    my $tied_obj = tied @{$data_ref};
    my $csv      = _create_csv_obj( %{$opts} );

    # do we have and want col/rownames?
    my %meta = map {
              $_ => defined $opts->{$_} ? $opts->{$_}
            : defined $tied_obj ? 1
            : 0
    } qw(row_names col_names);

    my @data = @{$data_ref};

    if ( $meta{row_names} ) {
        $meta{row_names}
            = reftype \$meta{row_names} eq 'SCALAR'
            ? rownames($data_ref)
            : $meta{row_names};
        @data
            = map { [ $meta{row_names}->[$_], @{ $data[$_] } ] } 0 .. $#data;
    }

    if ( $meta{col_names} ) {
        $meta{col_names}
            = reftype \$meta{col_names} eq 'SCALAR'
            ? colnames($data_ref)
            : $meta{col_names};
        unshift @data, $meta{col_names};
        if ( defined $opts->{hr} && $opts->{hr} ) {
            unshift @{ $data[0] }, q{};
        }
    }

    $csv->print( $IN, $_ ) for @data;

    return;
}

# parsing of the file in a 2d array, store column and row names.
sub _parse_fh {
    my ( $IN, $opts ) = @_;
    my @data;

    my $obj = tie @data, 'Text::CSV::R::Matrix';

    my $csv = _create_csv_obj( %{$opts} );

    # skip the first lines if option is set
    {
        local $. = 0;
        do { } while ( $. < $opts->{skip} && <$IN> );
    }

    my $max_cols = 0;
LINE:
    while ( my $line = <$IN> ) {
        chomp $line;

        # blank_lines_skip option
        next LINE if !length($line) && $opts->{'blank_lines_skip'};

        $csv->parse($line)
            or croak q{Cannot parse CSV: } . $csv->error_input();
        push @data, [ $csv->fields() ];
        if ( scalar( @{ $data[-1] } ) > $max_cols ) {
            $max_cols = scalar @{ $data[-1] };
        }

        # nrow option. Store one more because file might contain header.
        last LINE if ( $opts->{nrow} >= 0 && $. > $opts->{nrow} );
    }

   # If first line contains exactly one column less than the one with the
   # max. number of columns, we expect that first line contains the header and
   # first column the rownames (like read.tables does)
    my $auto_col_row = scalar @{ $data[0] || [] } == $max_cols - 1 ? 1 : 0;

    if ( defined $opts->{header} && !$opts->{header} ) {
        $auto_col_row = 0;
    }

    # in which column are rownames?
    my $rowname_id
        = ( defined $opts->{row_names}
            && reftype \$opts->{row_names} eq 'SCALAR' ) ? $opts->{row_names}
        : $auto_col_row ? 0
        :                 -1;

    # re-add the column name if it is omitted. use the same default name as R
    if ($auto_col_row) {
        unshift @{ $data[0] }, 'row.names';
    }

    if ( $auto_col_row || $opts->{header} ) {

        # first line contains header
        colnames( \@data, shift @data );
    }
    else {

        # no column names specified, then use the same default as R
        colnames( \@data, [ map { 'V' . $_ } 1 .. $max_cols ] );

        # we might have parsed one line more than needed with the nrow option,
        # so fix that if necessary
        if ( $opts->{nrow} >= 0 && $. > $opts->{nrow} ) {
            pop @data;
        }
    }

    my @rownames;
    if ( $rowname_id >= 0 ) {
        for my $row (@data) {
            push @rownames, splice @{$row}, $rowname_id, 1;
        }

        # remove the column from the colnames array
        my @colnames = @{ colnames( \@data ) };
        splice @colnames, $rowname_id, 1;
        colnames( \@data, \@colnames );
    }
    else {
        @rownames = 1 .. scalar @data;
    }
    rownames( \@data, \@rownames );

    return \@data;
}

1;

__END__