Consider:
string1 = "AAABBBBBCCCCCDDDDD"
string2 = "AEABBBBBCCECCDDDDD"
output. Where the mismatch (in this case E) will be replaced with HTML tags around E that color it.
A**E**ABBBBBCC**E**CCDDDDD
What I tried so far: XOR, diff and substr. First I need to find the indices then replace those indices with the pattern.
my #x = split '', "AAABBBBBCCCCCDDDDD";
my #y = split '', "AEABBBBBCCECCDDDDD";
my $result = join '',
map { $x[$_] eq $y[$_] ? $y[$_] : "**$y[$_]**" }
0 .. $#y;
Use:
use strict;
use warnings;
my $string1 = 'AAABBBBBCCCCCDDDDD';
my $string2 = 'AEABBBBBCCECCDDDDD';
my $result = '';
for(0 .. length($string1)) {
my $char = substr($string2, $_, 1);
if($char ne substr($string1, $_, 1)) {
$result .= "**$char**";
} else {
$result .= $char;
}
}
print $result;
It prints A**E**ABBBBBCC**E**CCDDDDD and was tested somewhat, but it may contain errors.
use warnings;
use strict;
my ($s1, $s2, $o1, $o2) = ("AAABBBBBCCCCCDDDDD", "AEABBBBBCCECCDDDDD");
my #s1 = split(//, $s1);
my #s2 = split(//, $s2);
my $eq_state = 1;
while (#s1 and #s2) {
if (($s1[0] eq $s2[0]) != $eq_state) {
$o1 .= (!$eq_state) ? "</b>" : "<b>";
$o2 .= (!$eq_state) ? "</b>" : "<b>";
}
$eq_state = $s1[0] eq $s2[0];
$o1.=shift #s1;
$o2.=shift #s2;
}
print "$o1\n$o2\n";
Output
A<b>A</b>ABBBBBCC<b>C</b>CCDDDDD
A<b>E</b>ABBBBBCC<b>E</b>CCDDDDD
A simpler one that only prints out the second string:
use warnings;
use strict;
my ($s1, $s2, $was_eq) = ("AAABBBBBCCCCCDDDDD", "AEABBBBBCCECCDDDDD", 1);
my #s1 = split(//, $s1);
my #s2 = split(//, $s2);
for my $idx (0 .. #s2 -1) {
my $is_eq = $s1[$idx] eq $s2[$idx];
print $is_eq ? "</b>" : "<b>" if ( $was_eq != $is_eq);
$was_eq = $is_eq;
print $s2[$idx];
}
Outout
</b>A<b>E</b>ABBBBBCC<b>E</b>CCDDDDD
This might be memory intensive, for large strings:
use strict;
use warnings;
my $a = "aabbcc";
my $b = "aabdcc";
my #a = split //, $a;
my #b = split //, $b;
my $new_b = '';
for(my $i = 0; $i < scalar(#a); $i++) {
$new_b .= $a[$i] eq $b[$i] ? $b[$i] : "**$b[$i]**";
}
Output
$ test.pl
new_b: aab**d**cc
There are several ways to accomplish this. Below is a possible way to solve this.
my $str1="ABCDEA";
my $str2="AECDEB";
my #old1=split("",$str1);
my #old2=split("",$str2);
my #new;
for my $i (0..$#old1) {
if ($old1[$i] eq $old2[$i] ) {
push (#new, $old2[$i]);
}
else
{
my $elem = "**".$old2[$i]."**";
push (#new , $elem);
}
}
print #new;
The output is:
A**E**CDE**B**
Aligning columns and using the bitwise string operator, "^":
my $a = "aabbccP";
my $b = "aabdccEE";
$_ = $a ^ $b;
s/./ord $& ? "^" : " "/ge;
print "$_\n" for $a, $b, $_;
gives:
aabbccP
aabdccEE
^ ^^
Related
i want to print truth table in to a table in an adt file, t got a program but i don know how to get vale or value to print to odt file, this program just print result on screen !
sub truth_table {
my $s = shift;
#print "$s\n";
my #vars;
for ($s =~ /([a-zA-Z_]\w*)/g) {
push #vars, $_ ;
}
#print "$s\n";
#print "$_\n";
#print Dumper \#vars;
#print "\n", join("\t", #vars, $s), "\n", '-' x 40, "\n";
#print Dumper \#vars;
#vars = map("\$$_", #vars);
$s =~ s/([a-zA-Z_]\w*)/\$$1/g;
$s = "print(".join(',"\t",', map("($_?'1':'0')", #vars, $s)).",\"\\n\")";
$s = "for my $_ (0, 1) { $s }" for (reverse #vars);
eval $s;
}
truth_table 'A ^ A_1';
Get the result of eval with Capture::Tiny, then split the string into a two-dimensional array based on https://stackoverflow.com/a/4226073/5100564.
use Capture::Tiny 'capture_stdout';
sub truth_table {
#...the rest of your code here...
my $stdout = capture_stdout {
eval $s;
};
return $stdout;
}
$truth_string = truth_table 'A ^ A_1';
my #truth_array;
foreach my $line (split "\n", $truth_string) {
push #truth_array, [split ' ', $line];
}
foreach my $line (#truth_array) {
foreach my $val (#$line) {
print $val;
}
print "\n";
}
For this to work, I executed the following commands based on What's the easiest way to install a missing Perl module?
cpan
install Capture::Tiny
However, I would solve this problem in LibreOffice with a Python macro instead. APSO makes it convenient to enter and run this code.
import uno
from itertools import product
def truth_table():
NUM_VARS = 2 # A and B
columns = NUM_VARS + 1
rows = pow(2, NUM_VARS) + 1
oDoc = XSCRIPTCONTEXT.getDocument()
oText = oDoc.getText()
oCursor = oText.createTextCursorByRange(oText.getStart())
oTable = oDoc.createInstance("com.sun.star.text.TextTable")
oTable.initialize(rows, columns)
oText.insertTextContent(oCursor, oTable, False)
for column, heading in enumerate(("A", "B", "A ^ B")):
oTable.getCellByPosition(column, 0).setString(heading)
row = 1 # the second row
for p in product((0, 1), repeat=NUM_VARS):
result = truth_function(*p)
for column in range(NUM_VARS):
oTable.getCellByPosition(column, row).setString(p[column])
oTable.getCellByPosition(column + 1, row).setString(result)
row += 1
def truth_function(x, y):
return pow(x, y);
g_exportedScripts = truth_table,
Using product in this way is based on Creating a truth table for any expression in Python.
More documentation for Python-UNO can be found at https://wiki.openoffice.org/wiki/Python.
I am very new at perl and had discovered the solution at:
Perl: Compare Two CSV Files and Print out differences
I have gone through dozens of other solutions and this comes closest, except that instead of finding the differences between 2 CSV files, I want to find where the second CSV file matches the first one in column and row. How could I modify the following script to find the matches in column/row instead of the differences. I am hoping to dissect this code and learn arrays from there, but wanted to find out the solution to this application. Much thanks.
use strict;
my #arr1;
my #arr2;
my $a;
open(FIL,"a.txt") or die("$!");
while (<FIL>)
{chomp; $a=$_; $a =~ s/[\t;, ]*//g; push #arr1, $a if ($a ne '');};
close(FIL);
open(FIL,"b.txt") or die("$!");
while (<FIL>)
{chomp; $a=$_; $a =~ s/[\t;, ]*//g; push #arr2, $a if ($a ne '');};
close(FIL);
my %arr1hash;
my %arr2hash;
my #diffarr;
foreach(#arr1) {$arr1hash{$_} = 1; }
foreach(#arr2) {$arr2hash{$_} = 1; }
foreach $a(#arr1)
{
if (not defined($arr2hash{$a}))
{
push #diffarr, $a;
}
}
foreach $a(#arr2)
{
if (not defined($arr1hash{$a}))
{
push #diffarr, $a;
}
}
print "Diff:\n";
foreach $a(#diffarr)
{
print "$a\n";
}
# You can print to a file instead, by: print FIL "$a\n";
ok, I realize that this was more what I was looking for:
use strict;
use warnings;
use feature qw(say);
use autodie;
use constant {
FILE_1 => "file1.txt",
FILE_2 => "file2.txt",
};
#
# Load Hash #1 with value from File #1
#
my %hash1;
open my $file1_fh, "<", FILE_1;
while ( my $value = <$file1_fh> ) {
chomp $value;
$hash1{$value} = 1;
}
close $file1_fh;
#
# Load Hash #2 with value from File #2
#
my %hash2;
open my $file2_fh, "<", FILE_2;
while ( my $value = <$file2_fh> ) {
chomp $value;
$hash2{$value} = 1;
}
close $file2_fh;
Now I want to search file2's hash to check if there are ANY matches from file1's hash. That is where I am stuck
With new code suggestion, code now looks like this
#!/usr/bin/env perl
use strict;
use warnings;
use feature qw(say);
use autodie;
use constant {
FILE_1 => "masterlist.csv",
FILE_2 => "pastebin.csv",
};
#
# Load Hash #1 with value from File #1
#
my %hash1;
open my $file1_fh, "<", FILE_1;
while ( my $value = <$file1_fh> ) {
chomp $value;
$hash1{$value} = 1;
}
close $file1_fh;
my %hash2;
open my $file2_fh, "<", FILE_2;
while ( my $value = <$file2_fh> ) {
chomp $value;
if ( $hash1{$value} ) {
print "Match found $value\n";
$hash2{$value}++;
}
}
close $file2_fh;
print "Matches found:\n";
foreach my $key ( keys %hash2 ) {
print "$key found $hash2{$key} times\n";
}
I updated one part with split() and it seems to work, but have to test more to confirm if it fits the solution I'm looking for or I have more work to do one it
#
# Load Hash #1 with value from File #1
#
my %hash1;
open my $file1_fh, "<", FILE_1;
while ( my $value = <$file1_fh> ) {
chomp $value;
$hash1{$value} = ( %hash1, (split(/,/, $_))[1,2] );
}
close $file1_fh;
So, with your code there - you've read in 'file1' to a hash.
Why not instead of reading file 2 into a hash, do instead:
my %hash2;
open my $file2_fh, "<", FILE_2;
while ( my $value = <$file2_fh> ) {
chomp $value;
if ( $hash1{$value} ) {
print "Match found $value\n";
$hash2{$value}++;
}
}
close $file2_fh;
print "Matches found:\n";
foreach my $key ( keys %hash2 ) {
print "$key found $hash2{$key} times\n";
}
I think this code identifies every place that a data field in file A matches a data field in file B (at least it does on my limited test data):
use strict;
use warnings;
my #arr1;
my #arr2;
# a.txt -> #arr1
my $file_a_name = "poster_a.txt";
open(FIL,$file_a_name) or die("$!");
my $a_line_counter = 0;
while (my $a_line = <FIL>)
{
$a_line_counter = $a_line_counter + 1;
chomp($a_line);
my #fields = (split /,/,$a_line);
my $num_fields = scalar(#fields);
s{^\s+|\s+$}{}g foreach #fields;
push #arr1, \#fields if ( $num_fields ne 0);
};;
close(FIL);
my $file_b_name = "poster_b.txt";
open(FIL,$file_b_name) or die("$!");
while (my $b_line = <FIL>)
{
chomp($b_line);
my #fields = (split /,/,$b_line);
my $num_fields = scalar(#fields);
s{^\s+|\s+$}{}g foreach #fields;
push #arr2, \#fields if ( $num_fields ne 0)
};
close(FIL);
# b.txt -> #arr2
#print "\n",#arr2, "\n";
my #match_array;
my $file_a_line_ctr = 1;
foreach my $file_a_line_fields (#arr1)
{
my $file_a_column_ctr = 1;
foreach my $file_a_line_field (#{$file_a_line_fields})
{
my $file_b_line_ctr = 1;
foreach my $file_b_line_fields(#arr2)
{
my $file_b_column_ctr = 1;
foreach my $file_b_field (#{$file_b_line_fields})
{
if ( $file_b_field eq $file_a_line_field )
{
my $match_info =
"$file_a_name line $file_a_line_ctr column $file_a_column_ctr" .
" (${file_a_line_field}) matches: " .
"$file_b_name line $file_b_line_ctr column $file_b_column_ctr ";
push(#match_array, $match_info);
print "$match_info \n";
}
$file_b_column_ctr = $file_b_column_ctr + 1;
}
$file_b_line_ctr = $file_b_line_ctr + 1;
}
$file_a_column_ctr = $file_a_column_ctr + 1;
}
$file_a_line_ctr = $file_a_line_ctr + 1;
}
print "there were ", scalar(#match_array)," matches\n";
I'm trying to count the number of bases using a for loop and the substr function but the counts are off and I'm not sure why! Please help! I have to use these functions in my assignment. Where am I going wrong? Here is my code:
use strict;
use warnings;
my $user_input = "accgtutf5";
#initalizing the lengths
my $a_base_total = 0;
my $c_base_total = 0;
my $g_base_total = 0;
my $t_base_total = 0;
my $other_total = 0;
for ( my $position = 0; $position < length $user_input; $position++ ) {
my $nucleotide = substr( $user_input, $position, 1 );
if ( $nucleotide eq "a" ) {
$a_base_total++;
} elsif ( $nucleotide eq "c" ) {
$c_base_total++;
} elsif ( $nucleotide eq "g" ) {
$g_base_total++;
} elsif ( $nucleotide eq "t" ) {
$t_base_total++;
} else {
$other_total++;
}
$position++;
}
print "a = $a_base_total\n";
print "c = $c_base_total\n";
print "g = $g_base_total\n";
print "t = $t_base_total\n";
print "other = $other_total\n";
The output I'm getting is :
a=1
c=1
g=0
t=2
other=1
When it should be:
a = 1
c = 2
g = 1
t = 2
other = 3
Thanks in advance! :)
You're incrementing twice.
Simply remove this line:
$position++;
Also, instead of iterating on position, I would suggest iterating on character.
Your script can be simplified to just:
use strict;
use warnings;
my $user_input = "accgtutf5";
my %count;
for my $nucleotide (split '', $user_input) {
$nucleotide = 'other' unless $nucleotide =~ /[acgt]/;
$count{$nucleotide}++;
}
printf "%s = %d\n", $_, $count{$_} // 0 for qw(a c g t other);
You are incrementing $position twice: once at the for and once at the end of the loop. Remove the second $position++.
I have two arrays:
#array1 = (A,B,C,D,E,F);
#array2 = (A,C,H,D,E,G);
The arrays could be of different size. I want to find how many mismatches are there between the arrays. The indexes should be the same. In this case there are three mismatch :b->c,c->h and F->G.(i.e , The 'C' in $array[2] should not be considered a match to 'C' in $array[1]) I would like to get the number of mismatches as well as the mismatch.
foreach my $a1 ( 0 .. $#array1) {
foreach my $a2( 0 .. $#array2)
if($array1[$a1] ne $array2[$a2]) {
}
}
}
my %array_one = map {$_, 1} #array1;
my #difference = grep {!$array_one {$_}} #array1;
print "#difference\n";
Ans: gives me H, G but not C.
with my little Perl knowledge I tried this, with no result. Could you suggest me how I should deal this? Your suggestions and pointers would be very helpful.
You shouldn't have nested loops. You only need to go through the indexes once.
use List::Util qw( max );
my #mismatches;
for my $i (0..max($#array1, $#array2)) {
push #mismatches, $i
if $i >= #array1
|| $i >= #array2
|| $array1[$i] ne $array2[$i];
}
}
say "There are " . (0+#mismatches) . " mismatches";
for my $i (#mismatches) {
...
}
Since you mentioned grep, this is how you'd replace the for with grep:
use List::Util qw( max );
my #mismatches =
grep { $_ >= #array1
|| $_ >= #array2
|| array1[$_] ne $array2[$_] }
0 .. max($#array1, $#array2);
say "There are " . (0+#mismatches) . " mismatches";
for my $i (#mismatches) {
...
}
Here's an example using each_arrayref from List::MoreUtils.
sub diff_array{
use List::MoreUtils qw'each_arrayref';
return unless #_ && defined wantarray;
my #out;
my $iter = each_arrayref(#_);
my $index = 0;
while( my #current = $iter->() ){
next if all_same(#current);
unshift #current, $index;
push #out, \#current;
}continue{ ++$index }
return #out;
}
This version should be faster if you are going to use this for determining the number of differences often. The output is exactly the same. It just doesn't have to work as hard when returning a number.
Read about wantarray for more information.
sub diff_array{
use List::MoreUtils qw'each_arrayref';
return unless #_ && defined wantarray;
my $iter = each_arrayref(#_);
if( wantarray ){
# return structure
my #out;
my $index = 0;
while( my #current = $iter->() ){
next if all_same(#current);
unshift #current, $index;
push #out, \#current;
}continue{ ++$index }
return #out;
}else{
# only return a count of differences
my $out = 0;
while( my #current = $iter->() ){
++$out unless all_same #current;
}
return $out;
}
}
diff_array uses the subroutine all_same to determine if all of the current list of elements are the same.
sub all_same{
my $head = shift;
return undef unless #_; # not enough arguments
for( #_ ){
return 0 if $_ ne $head; # at least one mismatch
}
return 1; # all are the same
}
To get just the number of differences:
print scalar diff_array \#array1, \#array2;
my $count = diff_array \#array1, \#array2;
To get a list of differences:
my #list = diff_array \#array1, \#array2;
To get both:
my $count = my #list = diff_array \#array1, \#array2;
The output for the input you provided:
(
[ 1, 'B', 'C' ],
[ 2, 'C', 'H' ],
[ 5, 'F', 'G' ]
)
Example usage
my #a1 = qw'A B C D E F';
my #a2 = qw'A C H D E G';
my $count = my #list = diff_array \#a1, \#a2;
print "There were $count differences\n\n";
for my $group (#list){
my $index = shift #$group;
print " At index $index\n";
print " $_\n" for #$group;
print "\n";
}
You're iterating over both arrays when you don't want to be doing so.
#array1 = ("A","B","C","D","E","F");
#array2 = ("A","C","H","D","E","G");
foreach my $index (0 .. $#array1) {
if ($array1[$index] ne $array2[$index]) {
print "Arrays differ at index $index: $array1[$index] and $array2[$index]\n";
}
}
Output:
Arrays differ at index 1: B and C
Arrays differ at index 2: C and H
Arrays differ at index 5: F and G
Well, first, you're going to want to go over each element of one of the arrays, and compare it to the same element of the other array. List::MoreUtils provides an easy way to do this:
use v5.14;
use List::MoreUtils qw(each_array);
my #a = qw(a b c d);
my #b = qw(1 2 3);
my $ea = each_array #a, #b;
while ( my ($a, $b) = $ea->() ) {
say "a = $a, b = $b, idx = ", $ea->('index');
}
You can extend that to find where there is a non-match by checking inside that while loop (note: this assumes your arrays don't have undefs at the end, or that if they do, undef is the same as having a shorter array):
my #mismatch;
my $ea = each_array #a, #b;
while ( my ($a, $b) = $ea->() ) {
if (defined $a != defined $b || $a ne $b) {
push #mismatch, $ea->('index');
}
}
and then:
say "Mismatched count = ", scalar(#mismatch), " items are: ", join(q{, }, #mismatch);
The following code builds a list of mismatched pairs, then prints them out.
#a1 = (A,B,C,D,E,F);
#a2 = (A,C,H,D,E,G);
#diff = map { [$a1[$_] => $a2[$_]] }
grep { $a1[$_] ne $a2[$_] }
(0..($#a1 < $#a2 ? $#a1 : $#a2));
print "$_->[0]->$_->[1]\n" for #diff
You have the right idea, but you only need a single loop, since you are looking at each index and comparing entries between the arrays:
foreach my $a1 ( 0 .. $#array1) {
if($array1[$a1] ne $array2[$a1]) {
print "$a1: $array1[$a1] <-> $array2[$a1]\n";
}
}
I've a set of strings with variable sizes, for example:
AAA23
AB1D1
A1BC
AAB212
My goal is have in alphabetical order and unique characters collected for COLUMNS, such as:
first column : AAAA
second column : AB1A
and so on...
For this moment I was able to extract the posts through a hash of hashes. But now, how can I sort data? Could I for each hash of hash make a new array?
Thank you very much for you help!
Al
My code:
#!/usr/bin/perl
use strict;
use warnings;
my #sessions = (
"AAAA",
"AAAC",
"ABAB",
"ABAD"
);
my $length_max = 0;
my $length_tmp = 0;
my %columns;
foreach my $string (#sessions){
my $l = length($string);
if ($l > $length_tmp){
$length_max = $l;
}
}
print "max legth : $length_max\n\n";
my $n = 1;
foreach my $string (#sessions){
my #ch = split("",$string);
for my $col (1..$length_max){
$columns{$n}{$col} = $ch[$col-1];
}
$n++;
}
foreach my $col (keys %columns) {
print "colonna : $col\n";
my $deref = $columns{$col};
foreach my $pos (keys %$deref){
print " posizione : $pos --> $$deref{$pos}\n";
}
print "\n";
}
exit(0);
What you're doing is rotating the array. It doesn't need a hash of hash or anything, just another array. Surprisingly, neither List::Util nor List::MoreUtils supplies one. Here's a straightforward implementation with a test. I presumed you want short entries filled in with spaces so the columns come out correct.
#!/usr/bin/perl
use strict;
use warnings;
use Test::More;
use List::Util qw(max);
my #Things = qw(
AAA23
AB1D1
A1BC
AAB212
);
sub rotate {
my #rows = #_;
my $maxlength = max map { length $_ } #rows;
my #columns;
for my $row (#rows) {
my #chars = split //, $row;
for my $colnum (1..$maxlength) {
my $idx = $colnum - 1;
$columns[$idx] .= $chars[$idx] || ' ';
}
}
return #columns;
}
sub print_columns {
my #columns = #_;
for my $idx (0..$#columns) {
printf "Column %d: %s\n", $idx + 1, $columns[$idx];
}
}
sub test_rotate {
is_deeply [rotate #_], [
"AAAA",
"AB1A",
"A1BB",
"2DC2",
"31 1",
" 2",
];
}
test_rotate(#Things);
print_columns(#Things);
done_testing;
You can sort the output of %columns in your code with
foreach my $i (sort { $a <=> $b } keys %columns) {
print join(" " => sort values %{ $columns{$i} }), "\n";
}
This gives
A A A A
A A A C
A A B B
A A B D
But using index numbers as hash keys screams that you should use an array instead, so let's do that. To get the columns, use
sub columns {
my #strings = #_;
my #columns;
while (#strings) {
push #columns => [ sort map s/^(.)//s ? $1 : (), #strings ];
#strings = grep length, #strings;
}
#columns;
}
Given the strings from your question, it returns
A A A A
1 A A B
1 A B B
2 2 C D
1 1 3
2
As you can see, this is unsorted and repeats characters. With Perl, when you see the word unique, always think of hashes!
sub unique_sorted_columns {
map { my %unique;
++$unique{$_} for #$_;
[ sort keys %unique ];
}
columns #_;
}
If you don't mind destroying information, you can have columns sort and filter duplicates:
sub columns {
my #strings = #_;
my #columns;
while (#strings) {
my %unique;
map { ++$unique{$1} if s/^(.)//s } #strings;
push #columns => [ sort keys %unique ];
#strings = grep length, #strings;
}
#columns;
}
Output:
A
1 A B
1 A B
2 C D
1 3
2