view release on metacpan or  search on metacpan

lib/Pheno/Ranker/IO.pm  view on Meta::CPAN

package Pheno::Ranker::IO;

use strict;
use warnings;
use autodie;
use feature qw(say);
use Path::Tiny;
use File::Basename;
use File::Spec::Functions  qw(catdir catfile);
use List::Util             qw(any);
use Hash::Util             qw(lock_hash);
use IO::Uncompress::Gunzip qw(gunzip $GunzipError);
use YAML::XS               qw(Load LoadFile DumpFile);
use JSON::XS;

#use Data::Dumper;

#use Sort::Naturally qw(nsort);
use Exporter 'import';
our @EXPORT =
  qw(serialize_hashes write_alignment io_yaml_or_json read_json read_yaml write_json write_array2txt array2object validate_json write_poi poi_output_filename coverage_stats check_existence_of_include_terms append_and_rename_primary_key restructure_px...
use constant DEVEL_MODE => 0;

#########################
#########################
#  SUBROUTINES FOR I/O  #
#########################
#########################

sub serialize_hashes {
    my $arg             = shift;
    my $data            = $arg->{data};
    my $export_basename = $arg->{export_basename};
    write_json(
        { data => $data->{$_}, filepath => qq/$export_basename.$_.json/ } )
      for keys %{$data};
    return 1;
}

sub write_alignment {
    my $arg       = shift;
    my $basename  = $arg->{align};
    my $ascii     = $arg->{ascii};
    my $dataframe = $arg->{dataframe};
    my $csv       = $arg->{csv};
    my %hash      = (
        '.txt'        => $ascii,
        '.csv'        => $dataframe,
        '.target.csv' => $csv
    );

    for my $key ( keys %hash ) {
        my $output = $basename . $key;
        write_array2txt( { filepath => $output, data => $hash{$key} } );
    }
    return 1;
}

sub io_yaml_or_json {
    my $arg  = shift;
    my $file = $arg->{filepath};
    my $mode = $arg->{mode};
    my $data = $mode eq 'write' ? $arg->{data} : undef;

    # Check if the file is gzipped
    my $is_gz = $file =~ /\.gz$/ ? 1 : 0;

    # Remove .gz for extension recognition if present
    my $file_for_ext = $is_gz ? ( $file =~ s/\.gz$//r ) : $file;

    # Allowed extensions
    my @exts = qw(.yaml .yml .json);

    # Use fileparse on the file name without the .gz suffix
    my ( undef, undef, $ext ) = fileparse( $file_for_ext, @exts );
    my $msg = qq(Can't recognize <$file> extension. Extensions allowed are: )
      . join ',', @exts;
    die $msg unless any { $_ eq $ext } @exts;

    # Unify extension by removing "a" and "."
    $ext =~
      tr/a.//d;   # so ".yaml" or ".yml" become "yml" and ".json" becomes "json"

    # Dispatch table for read/write operations
    my $return = {
        read  => { json => \&read_json,  yml => \&read_yaml },
        write => { json => \&write_json, yml => \&write_yaml },
    };

    # Call the appropriate function based on the mode and extension
    return $mode eq 'read'
      ? $return->{$mode}{$ext}->($file)
      : $return->{$mode}{$ext}->( { filepath => $file, data => $data } );
}

sub read_json {
    my $file = shift;
    my $str;
    if ( $file =~ /\.gz$/ ) {
        gunzip $file => \$str
          or die "gunzip failed for $file: $GunzipError\n";
    }
    else {
        $str = path($file)->slurp;
    }
    return decode_json($str);
}

sub read_yaml {
    my $file = shift;
    my $data;

    # Check if the file ends with .gz
    if ( $file =~ /\.gz$/ ) {
        my $yaml_str;
        gunzip $file => \$yaml_str
          or die "gunzip failed for $file: $GunzipError\n";

        # Decode the YAML from the string
        $data = Load($yaml_str);
    }
    else {
        # Directly load from the file
        $data = LoadFile($file);
    }
    return $data;
}

sub write_json {
    my $arg       = shift;
    my $file      = $arg->{filepath};
    my $json_data = $arg->{data};

    # Note that canonical DOES not match the order of nsort from Sort::Naturally
    my $json = JSON::XS->new->utf8->canonical->pretty->encode($json_data);
    path($file)->spew($json);
    return 1;
}

sub write_yaml {
    my $arg       = shift;
    my $file      = $arg->{filepath};
    my $json_data = $arg->{data};
    local $YAML::XS::Boolean = 'JSON::PP';
    DumpFile( $file, $json_data );
    return 1;
}

sub write_array2txt {
    my $arg  = shift;
    my $file = $arg->{filepath};
    my $data = $arg->{data};

    # Watch out for RAM usage!!!
    path($file)->spew_utf8( join( "\n", @$data ) . "\n" );
    return 1;
}

sub write_poi {
    my $arg         = shift;
    my $ref_data    = $arg->{ref_data};
    my $poi         = $arg->{poi};
    my $poi_out_dir = $arg->{poi_out_dir};
    my $primary_key = $arg->{primary_key};
    my $verbose     = $arg->{verbose};
    for my $name (@$poi) {
        my ($match) = grep { $name eq $_->{$primary_key} } @$ref_data;
        if ($match) {
            my $out = catfile( $poi_out_dir, poi_output_filename($name) );
            say "Writting <$out>" if $verbose;
            write_json( { filepath => $out, data => $match } );
        }
        else {
            warn
"No individual found for <$name>. Are you sure you used the right prefix?\n";
        }
    }
    return 1;
}

sub poi_output_filename {
    my ( $name, $portable ) = @_;
    $portable = $^O eq 'MSWin32' unless defined $portable;

    my $filename = defined $name ? "$name" : '';

    # Always encode path separators and percent to avoid directory traversal
    # and ambiguous percent-encoded names. Encode extra characters on Windows.
    my $unsafe = $portable
      ? qr/([<>:"\/\\|?*\x00-\x1F%])/
      : qr/([\/\\\x00-\x1F%])/;
    $filename =~ s/$unsafe/sprintf '%%%02X', ord($1)/eg;

    if ($portable) {