#!/usr/bin/perl --
use warnings; use strict;
use autodie;
Main( @ARGV );
exit( 0 );
sub Main {
#~     RegPosOut910992( 'testReg.txt', 'testPos.txt', 'testOut.txt' );
    if( @_ == 3 ){
        RegPosOut910992( @_ );
    } else {
        RPSDemo();
    }
}

sub RegPosOut910992 {
    my( $region, $position , $writeOut  )= @_;
    use autodie;
    open my $Reg, '<', $region;
    open my $Pos, '<', $position;
    open my $Out, '>', $writeOut;
    
RLINE:
    while( my $rline = <$Reg> ){
        my @r_arr = MeaningfullName( $rline );
        seek $Pos, 0,0; # Rewind!!!
PLINE:
        while( my $pline = <$Pos> ){
            my @p_arr = MeaningfullName( $pline );
            next PLINE if $p_arr[1] > $r_arr[2];
            if( IsMeaningfulName( \@p_arr, \@r_arr ) ){
                print $Out Laundromat( \@p_arr, \@r_arr ) ;
            }
        }
    }
} ## end sub RegPosOut910992

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",
            "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;
    $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__

    RegPosOut910992 ( \$region, \$position, \my $actualOutput );
    warn "\n$actualOutput\n";
    $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" );
} ## end sub RPSDemo

[download]

In reply to Re^6: Help with locating bp region in chromosome by Anonymous Monk
in thread Help with locating bp region in chromosome by Anonymous Monk

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.