Beefy Boxes and Bandwidth Generously Provided by pair Networks vroom
XP is just a number
 
PerlMonks  

Re: concatenating identical sequences

by BrowserUk (Pope)
on Oct 04, 2011 at 16:26 UTC ( #929594=note: print w/ replies, xml ) Need Help??


in reply to concatenating identical sequences

I'd use a similar approach to Limbic~Region, but I'd accumulate the blocks as strings rather than arrays as they consume considerably less space, which will put off the time when you need to use a multi-pass solution. Building an array of newly read IDs as you go, allows for retaining the original ordering on output.

This:

#! perl -slw use strict; my( $id, %accu, @order ); while( <DATA> ) { chomp; if( m[^(\S+_\S+_\S+)\s+(.+)\s*$] ) { $id = $1; unless( exists $accu{ $id } ) { push @order, $id; $accu{ $id } = $2; } else { $accu{ $id } .= ' ' . $2; } } else { $accu{ $id } .= ' ' . $_; } } for my $key ( @order ) { printf "%-10s %s\n", $key, substr( $accu{ $key }, 0, 55, '' ); print substr( $accu{ $key }, 0, 66, '' ) while length $accu{ $key +}; print ''; } __DATA__ 5390_7_9 MEWYKKIGLL ATTGLALVGL GACSNYGKSA DGTVTIEYFN QKKEMTKTLE EITRDFEKEN PKIKVKVVNV PNAGEVLKTR VLAGDVPDVV NIYPQSIELQ EWAKAGVFED 5390_8_1 MKWYKKIGLL ATTGLALVGL GACSNYGKSA DGTVTIEYFN QKKEMTKTLE EITRDFEKEN PKIKVKVVNV PNAGEVLKTR VLAGDVPDVV NIYPQSIELQ EWAKAGVFED 5390_8_2 MEWYKKIGLL ATTALALFGL GACSNYGKSA DDTVTIEYFN QKKEMTKILE EITRDFEKEN SKIKVKVVNV PNAGEVLKTR VLAGDVPDVV NIYPQSIELQ EWAKAGVFED 5390_7_9 MEWYKKIGLL ATTGLALVGL GACSNYGKSA DGTVTIEYFN QKKEMTKTLE EITRDFEKEN PKIKVKVVNV PNAGEVLKTR VLAGDVPDVV NIYPQSIELQ EWAKAGVFED LSNKDYLKRV KNGYAEKYAV NEKVYNVPFT ANAYGIYYNK DKFEELGLKV PETWDEFEQL 5390_8_1 MKWYKKIGLL ATTGLALVGL GACSNYGKSA DGTVTIEYFN QKKEMTKTLE 5390_8_2 MEWYKKIGLL ATTALALFGL GACSNYGKSA DDTVTIEYFN QKKEMTKILE EITRDFEKEN SKIKVKVVNV PNAGEVLKTR VLAGDVPDVV NIYPQSIELQ EWAKAGVFED LSNKDYLKRV KNGYAEKYAV NEKVYNVPFT ANAYGIYYNK DKFEELGLKV PETWDEFEQL

Produces:

C:\test>junk35 5390_7_9 MEWYKKIGLL ATTGLALVGL GACSNYGKSA DGTVTIEYFN QKKEMTKTLE EITRDFEKEN PKIKVKVVNV PNAGEVLKTR VLAGDVPDVV NIYPQSIELQ EWAKAGVFED MEWYKKIGLL ATTGLALVGL GACSNYGKSA DGTVTIEYFN QKKEMTKTLE EITRDFEKEN PKIKVKVVNV PNAGEVLKTR VLAGDVPDVV NIYPQSIELQ EWAKAGVFED LSNKDYLKRV KNGYAEKYAV NEKVYNVPFT ANAYGIYYNK DKFEELGLKV PETWDEFEQL 5390_8_1 MKWYKKIGLL ATTGLALVGL GACSNYGKSA DGTVTIEYFN QKKEMTKTLE EITRDFEKEN PKIKVKVVNV PNAGEVLKTR VLAGDVPDVV NIYPQSIELQ EWAKAGVFED MKWYKKIGLL ATTGLALVGL GACSNYGKSA DGTVTIEYFN QKKEMTKTLE 5390_8_2 MEWYKKIGLL ATTALALFGL GACSNYGKSA DDTVTIEYFN QKKEMTKILE EITRDFEKEN SKIKVKVVNV PNAGEVLKTR VLAGDVPDVV NIYPQSIELQ EWAKAGVFED MEWYKKIGLL ATTALALFGL GACSNYGKSA DDTVTIEYFN QKKEMTKILE EITRDFEKEN SKIKVKVVNV PNAGEVLKTR VLAGDVPDVV NIYPQSIELQ EWAKAGVFED LSNKDYLKRV KNGYAEKYAV NEKVYNVPFT ANAYGIYYNK DKFEELGLKV PETWDEFEQL

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.


Comment on Re: concatenating identical sequences
Select or Download Code
Re^2: concatenating identical sequences
by $new_guy (Acolyte) on Oct 05, 2011 at 05:49 UTC

    Thanks Limbic~Region and BrowserUk for your good advice. I have had a quick go with BrowserUk's script and it seems to work OK. However, the merge is not so clean and results after the merge seem not to be in equal chunks (I have posted this on to my scratchpad). I am speculating that this will continue as > continue to add more block (i.e thousands). I have adapted your script as follows:

    #! perl -slw use strict; if (scalar(@ARGV) != 1) { print "\n"; print "Usage: script.pl <alignment file>"; print "\n"; exit(); } my ($FILENAME) = @ARGV; #read in file open(DATA, $FILENAME); my( $id, %accu, @order ); ## remove existing files my $remove = "new_alignment_".$FILENAME; #remove any existing results + file if (unlink($remove) == 1) { print "Existing \"$remove\" file was removed\n +"; } ## generate a temporary storage file my $outputfile = "new_alignment_".$FILENAME; #make a big file in which + the final results will be printed unless ( open(POS, ">>$outputfile") ) { print "Cannot open file \"$outputfile\" to write to!!\n\n"; exit; } while( <DATA> ) { chomp; if( m[^(\S+_\S+_\S+)\s+(.+)\s*$] ) { $id = $1; unless( exists $accu{ $id } ) { push @order, $id; $accu{ $id } = $2; } else { $accu{ $id } .= ' ' . $2; } } else { $accu{ $id } .= ' ' . $_; } } for my $key ( @order ) { printf POS "%-10s %s\n", $key, substr( $accu{ $key }, 0, 55, '' ); print POS substr( $accu{ $key }, 0, 66, '' ) while length $accu{ $ +key }; print POS ''; }
    I must also confess I do not understand the last bit of code:
    for my $key ( @order ) { printf POS "%-10s %s\n", $key, substr( $accu{ $key }, 0, 55, '' ); print POS substr( $accu{ $key }, 0, 66, '' ) while length $accu{ $ +key }; print POS ''; }
    Could you kindly please explain it to me.

    PS: Still thinking of how to implement what Limbic~Region has pointed out.

    $new_guy

      However, the merge is not so clean and results after the merge seem not to be in equal chunks (I have posted this on to my scratchpad).

      I missed this bit of your spec: "(except for the very last chunk at the end of each block which might be shorter than 10 letters)".

      Looks like you'll have to use Limbic~Region's solution of splitting the lines and storing the data as arrays.


      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.

      Or you could try this version first:

      #! perl -slw use strict; my( $id, %accu, @order ); while( <DATA> ) { chomp; if( m[^(\S+_\S+_\S+)\s+(.+)\s*$] ) { $id = $1; unless( exists $accu{ $id } ) { push @order, $id; $accu{ $id } = $2; } else { $accu{ $id } .= ' ' . $2; } } else { my $pad = 10 - length() % 11; $accu{ $id } .= ' ' . $_ . ' ' x $pad; } } for my $key ( @order ) { printf "%-10s %s\n", $key, substr( $accu{ $key }, 0, 55, '' ); print substr( $accu{ $key }, 0, 66, '' ) while length $accu{ $key +}; print ''; }

      Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
      "Science is about questioning the status quo. Questioning authority".
      In the absence of evidence, opinion is indistinguishable from prejudice.

        It works like a charm, thank you very much BrowserUk

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://929594]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others surveying the Monastery: (13)
As of 2014-04-16 16:25 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (432 votes), past polls