#!/usr/bin/perl --
use warnings; use strict;
use autodie;

Main( @ARGV );
exit( 0 );
sub Main {
#~     RPSFiles( @_ );
#~     RPSFiles( 'testReg.txt', 'testPos.txt', 'testOut.txt' );
    RPSDemo();
}

sub RPSFiles{
    my( $region, $position , $writeOut  ) = @_;
    use autodie; # die if open/close..... fails
    open my $Reg, '<', $region;
    open my $Pos, '<', $position;
    open my $Out, '>', $writeOut;
    RegPosOut910992 ( $Reg, $Pos, $Out );
    close $Reg;
    close $Pos;
    close $Out;
}

sub RegPosOut910992 {
    my( $Reg, $Pos, $Out ) = @_;

#~     my $rline; 
#~     my $pline; 


    RLINE: while (my $rline=<$Reg>) {
#~         chomp($rline);
#~             my @r_arr=split("\t",$rline);
#~                 
#~                 chomp($r_arr[0]);
#~                 my @rID = split("r",$r_arr[0]);
#~                 $r_arr[0] = $rID[1]; #this removes the "chr" portio
+n of the first element and leaves number
#~                 #i.e. instead of [0] -> "chr24"; [0] -> "24"
        my @r_arr = MeaningfullName( $rline );

        seek $Pos, 0,0; # Rewind!!!
        PLINE: while(my $pline=<$Pos>) {            
#~                 if(!$rline) {
#~                     last;
#~                 }
            
#~             chomp($pline);
#~                 my @p_arr=split("\t",$pline);
#~                 
#~                     chomp($p_arr[0]);
#~                     my @pID = split("r",$p_arr[0]);
#~                     $p_arr[0] = $pID[1];
            my @p_arr = MeaningfullName( $pline );
            
                if($p_arr[1] > $r_arr[2]) {
#~                   $rline=<$Reg>; 
#~                   redo;
                  next PLINE;
                }
            
                else {                
#~                       if($p_arr[0] == $r_arr[0] && $p_arr[1] >= $r_
+arr[1] && $p_arr[1] <= $r_arr[2]) {
                      if( IsMeaningfulName( \@p_arr, \@r_arr ) ) {
#~                         #NOTE: [0] element in each array now corres
+ponds to chr number
#~                         # r[1] is start of region and r[2] is end o
+f region
#~                         # p[1] is the position of the base pair
#~                         shift(@p_arr);
#~                         print ($Out "chr$r_arr[0]\t$r_arr[1]\t$r_ar
+r[2]\t$r_arr[3]\t"); 
#~                             print $Out join ("\t", @p_arr), "\n"; 
#~                             #essentially I'm joining the two files 
+with matching lines
#~                             #w/ columns separated by tab
                            print $Out Laundromat( \@p_arr, \@r_arr ) 
+;
                       }
                }
        } 
    }
#~     close $Reg;
#~     close $Pos;
#~     close $Out;

}

sub Laundromat {
    my ( $p_arr , $r_arr ) = @_;
    return
        "chr$$r_arr[0]\t$$r_arr[1]\t$$r_arr[2]\t$$r_arr[3]\t"
        . join (
            "\t",
#~             @{$p_arr}[ 1 .. $#$p_arr ],
            "chr$$p_arr[0]",
            @{$p_arr}[ 1 .. $#$p_arr ],
        ), "\n";
}


sub IsMeaningfulName {
    my ( $p_arr , $r_arr ) = @_;
    return scalar(
        $$p_arr[0] == $$r_arr[0]
        and
        $$p_arr[1] >= $$r_arr[1]
        and
        $$p_arr[1] <= $$r_arr[2]
    );
}

sub MeaningfullName {
    my @eaning = grep length, split /\s+/, shift;
#~ use YAPE::Regex::Explain ;
#~ die YAPE::Regex::Explain->new(qr/\D/)->explain;
    $eaning[0] =~ s/\D//g;
    return @eaning;
}

sub RPSDemo {
#~ http://perlmonks.com/?abspart=1;displaytype=displaycode;node_id=911
+103;part=2
    my $region = <<'__REGION__';
chr1    100    159    0
chr1    200    260    0
chr1    500    750    0
chr3    450    700    0
chr4    100    300    0
chr7    350    600    0
chr9    100    125    0
chr11    679    687    0
chr22    100    200    0
chr22    300    400    0
__REGION__

#~ http://perlmonks.com/?abspart=1;displaytype=displaycode;node_id=911
+103;part=1
    my $position = <<'__POSITION__';
chr1    104    104    0    0    +
chr1    145    145    0    0    +
chr1    205    205    0    0    +
chr1    600    600    0    0    +
chr3    500    500    0    0    +
chr4    150    150    0    0    +
chr4    175    175    0    0    +
chr7    400    400    0    0    +
chr7    550    550    0    0    +
chr9    100    100    0    0    +
chr11    680    680    0    0    +
chr11    681    681    0    0    +
chr22    105    105    0    0    +
chr22    110    110    0    0    +
chr22    350    350    0    0    +
__POSITION__

#~ 2011-06-24-16:23:33
#~ http://perlmonks.com/?abspart=1;displaytype=displaycode;node_id=911
+112;part=1
    my $wantedOutput = <<'__CORRECT_OUTPUT__';
chr1    100    159    0    chr1    104    104    0    0    +
chr1    100    159    0    chr1    145    145    0    0    +
chr1    200    260    0    chr1    205    205    0    0    +
chr1    500    750    0    chr1    600    600    0    0    +
chr3    450    700    0    chr3    500    500    0    0    +
chr4    100    300    0    chr4    150    150    0    0    +
chr4    100    300    0    chr4    175    175    0    0    +
chr7    350    600    0    chr7    400    400    0    0    +
chr7    350    600    0    chr7    550    550    0    0    +
chr9    100    125    0    chr9    100    100    0    0    +
chr11    679    687    0    chr11    680    680    0    0    +
chr11    679    687    0    chr11    681    681    0    0    +
chr22    100    200    0    chr22    105    105    0    0    +
chr22    100    200    0    chr22    110    110    0    0    +
chr22    300    400    0    chr22    350    350    0    0    +
__CORRECT_OUTPUT__

    open my $Reg, '<', \$region;
    open my $Pos, '<', \$position;
    open my $Out, '>', \my $actualOutput;
    
#~     RegPosOut910992 ( $Reg, $Pos, \*STDOUT );
    RegPosOut910992 ( $Reg, $Pos, $Out );
    
    $wantedOutput =~ s/[\r\n]+/\n/g; # just in case
    $actualOutput =~ s/[\r\n]+/\n/g;
    require Test::More;
    Test::More->import(qw' tests 1 ');
    Test::More::is( $wantedOutput , $actualOutput, "RPSDemo works" );
}
[download]