File Coverage

blib/lib/App/RL/Command/stat.pm
Criterion Covered Total %
statement 92 95 96.8
branch 17 22 77.2
condition n/a
subroutine 12 12 100.0
pod 6 7 85.7
total 127 136 93.3


line stmt bran cond sub pod time code
1             package App::RL::Command::stat;
2 15     15   15857 use strict;
  15         50  
  15         637  
3 15     15   105 use warnings;
  15         34  
  15         587  
4 15     15   89 use autodie;
  15         50  
  15         123  
5              
6 15     15   105310 use App::RL -command;
  15         59  
  15         278  
7 15     15   8423 use App::RL::Common;
  15         52  
  15         24464  
8              
9             sub abstract {
10 2     2 1 98 return 'coverage statistics on chromosomes for runlists';
11             }
12              
13             sub opt_spec {
14             return (
15 7     7 1 121 [ "outfile|o=s", "output filename. [stdout] for screen" ],
16             [ "size|s=s", "chr.sizes", { required => 1 } ],
17             [ "remove|r", "remove 'chr0' from chromosome names" ],
18             [ "mk", "YAML file contains multiple sets of runlists" ],
19             [ "all", "only write whole genome stats" ],
20             { show_defaults => 1, }
21             );
22             }
23              
24             sub usage_desc {
25 7     7 1 101699 return "runlist stat [options] ";
26             }
27              
28             sub description {
29 1     1 1 2548 my $desc;
30 1         9 $desc .= ucfirst(abstract) . ".\n";
31 1         8 return $desc;
32             }
33              
34             sub validate_args {
35 5     5 1 11435 my ( $self, $opt, $args ) = @_;
36              
37 5 100       19 if ( @{$args} != 1 ) {
  5         34  
38 1         4 my $message = "This command need one input file.\n\tIt found";
39 1         4 $message .= sprintf " [%s]", $_ for @{$args};
  1         6  
40 1         7 $message .= ".\n";
41 1         59 $self->usage_error($message);
42             }
43 4         15 for ( @{$args} ) {
  4         16  
44 4 50       26 next if lc $_ eq "stdin";
45 4 100       33 if ( !Path::Tiny::path($_)->is_file ) {
46 1         214 $self->usage_error("The input file [$_] doesn't exist.");
47             }
48             }
49              
50 3 50       443 if ( !exists $opt->{outfile} ) {
51 0         0 $opt->{outfile} = Path::Tiny::path( $args->[0] )->absolute . ".csv";
52             }
53             }
54              
55             sub execute {
56 3     3 1 29 my ( $self, $opt, $args ) = @_;
57              
58             #----------------------------#
59             # Loading
60             #----------------------------#
61 3         9 my $infile; # YAML::Syck::LoadFile handles IO::*
62 3 50       16 if ( lc $args->[0] eq 'stdin' ) {
63 0         0 $infile = *STDIN;
64             }
65             else {
66 3         11 $infile = $args->[0];
67             }
68              
69 3         36 my $length_of = App::RL::Common::read_sizes( $opt->{size}, $opt->{remove} );
70              
71 3         14 my $s_of = {};
72 3         12 my @keys;
73 3 100       18 if ( $opt->{mk} ) {
74 1         8 my $yml = YAML::Syck::LoadFile($infile);
75 1         241 @keys = sort keys %{$yml};
  1         10  
76              
77 1         4 for my $key (@keys) {
78             $s_of->{$key}
79 5         30 = App::RL::Common::runlist2set( $yml->{$key}, $opt->{remove} );
80             }
81             }
82             else {
83 2         9 @keys = ("__single");
84             $s_of->{__single}
85 2         17 = App::RL::Common::runlist2set( YAML::Syck::LoadFile($infile), $opt->{remove} );
86             }
87              
88             #----------------------------#
89             # Calcing
90             #----------------------------#
91 3         38 my $out_fh;
92 3 50       27 if ( lc( $opt->{outfile} ) eq "stdout" ) {
93 3         25 $out_fh = *STDOUT;
94             }
95             else {
96 0         0 open $out_fh, ">", $opt->{outfile};
97             }
98              
99 3         12 my $header = sprintf "key,chr,chr_length,size,coverage\n";
100 3 100       18 if ( $opt->{mk} ) {
101 1 50       8 if ( $opt->{all} ) {
102 1         12 $header =~ s/chr\,//;
103             }
104 1         7 my @lines = ($header);
105              
106 1         4 for my $key (@keys) {
107 5         14 my @key_lines = csv_lines( $s_of->{$key}, $length_of, $opt->{all} );
108 5         17 $_ = "$key,$_" for @key_lines;
109 5         13 push @lines, @key_lines;
110             }
111              
112 1         3 print {$out_fh} $_ for @lines;
  6         108  
113             }
114             else {
115 2         22 $header =~ s/key\,//;
116 2 100       10 if ( $opt->{all} ) {
117 1         5 $header =~ s/chr\,//;
118             }
119 2         8 my @lines = ($header);
120              
121 2         15 push @lines, csv_lines( $s_of->{__single}, $length_of, $opt->{all} );
122 2         11 print {$out_fh} $_ for @lines;
  20         299  
123             }
124              
125 3         65 close $out_fh;
126             }
127              
128             sub csv_lines {
129 7     7 0 12 my $set_of = shift;
130 7         13 my $length_of = shift;
131 7         13 my $all = shift;
132              
133 7         9 my @lines;
134 7         13 my ( $all_length, $all_size, $all_coverage );
135 7         13 for my $chr ( sort keys %{$set_of} ) {
  7         45  
136 37         112 my $length = $length_of->{$chr};
137 37         145 my $size = $set_of->{$chr}->size;
138 37         12504 my $coverage = sprintf "%.4f", $size / $length;
139              
140 37         71 $all_length += $length;
141 37         56 $all_size += $size;
142              
143 37         221 push @lines, "$chr,$length,$size,$coverage\n";
144             }
145 7         38 $all_coverage = sprintf "%.4f", $all_size / $all_length;
146              
147             # only keep whole genome
148 7         27 my $all_line = "all,$all_length,$all_size,$all_coverage\n";
149 7 100       22 if ($all) {
150 6         28 @lines = ();
151 6         29 $all_line =~ s/all,//;
152             }
153 7         17 push @lines, $all_line;
154              
155 7         25 return @lines;
156             }
157              
158             1;