File Coverage

blib/lib/App/RL/Command/stat.pm
Criterion Covered Total %
statement 94 97 96.9
branch 17 22 77.2
condition n/a
subroutine 12 12 100.0
pod 5 6 83.3
total 128 137 93.4


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