How can I find the number of times a word is in a block of text in Perl?
For example my text file is this:
#! /usr/bin/perl -w
# The 'terrible' program - a poorly formatted 'oddeven'.
use constant HOWMANY => 4; $count = 0;
while ( $count < HOWMANY ) {
$count++;
if ( $count == 1 ) {
print "odd\n";
} elsif ( $count == 2 ) {
print "even\n";
} elsif ( $count == 3 ) {
print "odd\n";
} else { # at this point $count is four.
print "even\n";
}
}
I want to find the number of "count" word for that text file. File is named terrible.pl
Idealy it should use regex and with minimum number of line of code.
EDIT: This is what I have tried:
use IO::File;
my $fh = IO::File->new('terrible.pl', 'r') or die "$!\n";
my %words;
while (<$fh>) {
for my $word ($text =~ /count/g) {
print "x";
$words{$word}++;
}
}
print $words{$word};
Here's a complete solution. If this is homework, you learn more by explaining this to your teacher than by rolling your own:
perl -0777ne "print+(##=/count/g)+0" terrible.pl
If you are trying to count how many times appears the word "count", this will work:
my $count=0;
open(INPUT,"<terrible.pl");
while (<INPUT>) {
$count++ while ($_ =~ /count/g);
}
close(INPUT);
print "$count times\n";
I'm not actually sure what your example code is but you're almost there:
perl -e '$text = "lol wut foo wut bar wut"; $count = 0; $count++ while $text =~ /wut/g; print "$count\n";'
You can use the /g modifier to continue searching the string for matches. In the example above, it will return all instances of the word 'wut' in the $text var.
You can probably use something like so:
my $fh = IO::File->new('test.txt', 'r') or die "$!\n";
my %words;
while (<$fh>) {
for my $word (split / /) {
$words{$word}++;
}
}
That will give you an accurate count of every "word" (defined as a group of characters separated by a space), and store it in a hash which is keyed by the word with a value of the number of the word which was seen.
perdoc perlrequick has an answer. The term you want in that document is "scalar context".
Given that this appears to be a homework question, I'll point you at the documentation instead.
So, what are you trying to do? You want the number of times something appears in a block of text. You can use the Perl grep function. That will go through a block of text without needing to loop.
If you want an odd/even return value, you can use the modulo arithmetic function. You can do something like this:
if ($number % 2) {
print "$number is odd\n"; #Returns a "1" or true
}
else {
print "$number is even\n"; #Returns a "0" or false
}
Related
How can I print and get index from regex here:
my $search1 = "aaaNAMEaaaa";
my $search2 = "bbbbCHECKbbb";
if ( $search1 =~ /na\we/i and $search2 =~ /che\wk/i ) {
print "String found\n";
# This works with one search
# my $matched = $&;
# my $pos = index( $search1, $matched );
}
If both expressions match, $& will only have the last match. i.e. for the example above $& will always have the value CHECK and never have NAME because it was overwritten by the second pattern match.
You can wrap this logic in a function, then call that function as many times as you'd like with different string, pattern combinations:
use strict;
use warnings;
my $search1 = "aaaNAMEaaaa";
my $search2 = "bbbbCHECKbbb";
print index_from_match($search1, qr/na\we/i), "\n"; # 3
print index_from_match($search2, qr/che\wk/i), "\n"; # 4
print index_from_match($search1, qr/che\wk/i), "\n"; # -1
sub index_from_match {
my ($s, $pattern) = #_;
# uses a capture group instead of $&
if ( my ($match) = $s =~ m/($pattern)/ ) {
return index($s, $match);
}
return -1;
}
The core problem is that you're doing two regex comparisons in a single expression, so the values for the first one are lost before they can be processed
It's really hard to see how to help you without understanding the program flow within the conditional statement and how you actually use those values
Other languages use the idea of a match object, and it's easy to simulate that here by writing a subroutine that returns either a [ string, offset ] pair if the pattern matched, or undef if not. It's also less wasteful to use the built-in #- and #+ arrays to provide the values needed instead of repeating the search with index
It would look like this
use strict;
use warnings 'all';
use Carp 'croak';
my $search1 = 'aaaNAMEaaaa';
my $search2 = 'bbbbCHECKbbb';
my $match1 = match($search1, /na\we/i);
my $match2 = match($search2, qr/che\wk/i);
if ( $match1 and $match2 ) {
print "String found\n";
printf qq{"%s" found at offset %d\n}, #$match1;
printf qq{"%s" found at offset %d\n}, #$match2;
}
sub match {
my ($s, $re) = #_;
croak "Compiled regex required" unless ref $re eq 'Regexp';
return unless $s =~ $re;
[ substr($s, $-[0], $+[0]-$-[0]), $-[0] ];
}
output
String found
"NAME" found at offset 3
"CHECK" found at offset 4
I think it would also be neater to write this as
my $match1 = match($search1, qr/na\we/i);
my $match2 = match($search2, qr/che\wk/i);
if ( $match1 and $match2 ) {
print "String found\n";
printf qq{"%s" found at offset %d\n}, #$match1;
printf qq{"%s" found at offset %d\n}, #$match2;
}
Break your compound if into multiple if statements
my $search1 = "aaaNAMEaaaa";
my $search2 = "bbbbCHECKbbb";
my ($matched1, $matched2, $pos1, $pos2);
if ( $search1 =~ /na\we/i) {
$matched1 = $&;
$pos1 = index( $search1, $matched1);
if ($search2 =~ /che\wk/i ) {
print "String found\n";
$matched2 = $&;
$pos2 = index( $search2, $matched2);
#do whatever you need with $pos1 & $pos2
} else {
#reset previously set vars
undef $matched1;
undef $pos1;
}
}
A file.txt file contains the string "hello the apple cost 10.99 today"
How can I extract the 10.99 only?
This is what I have so far:
open READFILE, ("<file.txt");
while (<READFILE>)
{
if ($a = $_ =~ m/\d\.\d/)
{
print "$a\n";
}
}
However, my output shows 1 instead of 10.99. Can you please tell me what's wrong?
The 1 you were getting was indicating that there was a match. You need brackets to capture the match.
open READFILE, "<file.txt";
while (<READFILE>)
{
if (m/([\d\.]+)/)
{
my $price = $1;
print "price = $price\n";
}
}
open READFILE, "file.txt";
while (<READFILE>)
{
if ($_ =~ /(\d+\.\d+)/)
{
print "$1\n";
}
}
You are good to go
Change your code to this,
while (my $a = <DATA>) {
if ($a =~ s/.*?(\d+\.\d+).*/$1/)
{
print "$a\n";
}
}
s/regex/replacement/modifiers
s/.*?(\d+\.\d+).*/$1/ All characters are matched except the decimal point number. This number was captured by a capturing group. Replacing all the chars with the chars inside group index 1 will give only the decimal point number. That particular number was assigned to the variable a.
OR
while (my $a = <DATA>) {
if ($a =~ m/.*?(\d+\.\d+).*/)
{
print "$1\n";
}
}
The regex .*?(\d+\.\d+).* was matched against the input string and on successful match, decimal point number from the input string was captured. By printing the group index 1 will give you the stored decimal point number.
I have a series of lines such as
my $string = "home test results results-apr-25 results-apr-251.csv";
#str = $string =~ /(\w+)\1+/i;
print "#str";
How do I find the largest repeating string with overlap which are separated by whitespace?
In this case I'm looking for the output :
results-apr-25
It looks like you need the String::LCSS_XS which calculates Longest Common SubStrings. Don't try it's Perl-only twin brother String::LCSS because there are bugs in that one.
use strict;
use warnings;
use String::LCSS_XS;
*lcss = \&String::LCSS_XS::lcss; # Manual import of `lcss`
my $var = 'home test results results-apr-25 results-apr-251.csv';
my #words = split ' ', $var;
my $longest;
my ($first, $second);
for my $i (0 .. $#words) {
for my $j ($i + 1 .. $#words) {
my $lcss = lcss(#words[$i,$j]);
unless ($longest and length $lcss <= length $longest) {
$longest = $lcss;
($first, $second) = #words[$i,$j];
}
}
}
printf qq{Longest common substring is "%s" between "%s" and "%s"\n}, $longest, $first, $second;
output
Longest common substring is "results-apr-25" between "results-apr-25" and "results-apr-251.csv"
my $var = "home test results results-apr-25 results-apr-251.csv";
my #str = split " ", $var;
my %h;
my $last = pop #str;
while (my $curr = pop #str ) {
if(($curr =~/^$last/) || $last=~/^$curr/) {
$h{length($curr)}= $curr ;
}
$last = $curr;
}
my $max_key = max(keys %h);
print $h{$max_key},"\n";
If you want to make it without a loop, you will need the /g regex modifier.
This will get you all the repeating string:
my #str = $string =~ /(\S+)(?=\s\1)/ig;
I have replaced \w with \S (in your example, \w doesn't match -), and used a look-ahead: (?=\s\1) means match something that is before \s\1, without matching \s\1 itself—this is required to make sure that the next match attempt starts after the first string, not after the second.
Then, it is simply a matter of extracting the longest string from #str:
my $longest = (sort { length $b <=> length $a } #str)[0];
(Do note that this is a legible but far from being the most efficient way of finding the longest value, but this is the subject of a different question.)
How about:
my $var = "home test results results-apr-25 results-apr-251.csv";
my $l = length $var;
for (my $i=int($l/2); $i; $i--) {
if ($var =~ /(\S{$i}).*\1/) {
say "found: $1";
last;
}
}
output:
found: results-apr-25
The point of the overall script is to:
step 1) open a single column file and read off first entry.
step 2) open a second file containing lots of rows and columns, read off EACH line one at a time, and find anything in that line that matches the first entry from the first file.
step3) if a match is found, then "do something constructive", and if not, go to the first file and take the second entry and repeat step 2 and step 3, and so on...
here is the script:
#!/usr/bin/perl
use strict; #use warnings;
unless(#ARGV) {
print "\usage: $0 filename\n\n"; # $0 name of the program being executed
exit;
}
my $list = $ARGV[0];
chomp( $list );
unless (open(LIST, "<$list")) {
print "\n I can't open your list of genes!!! \n";
exit;
}
my( #list ) = (<LIST>);
close LIST;
open (CHR1, "<acembly_chr_sorted_by_exon_count.txt") or die;
my(#spreadsheet) = (<CHR1>);
close CHR1;
for (my $i = 0; $i < scalar #list; $i++ ) {
print "$i in list is $list[$i]\n";
for (my $j = 1; $j < scalar #spreadsheet; $j++ ) {
#print "$spreadsheet[$j]\n";
if ( $spreadsheet[$j] ) {
print "will $list[$i] match with $spreadsheet[$j]?\n";
}
else { print "no match\n" };
} #for
} #for
I plan to use a regex in the line if ( $spreadsheet[$j] ) { but am having a problem at this step as it is now. On the first interation, the line print "will $list[$i] match with $spreadsheet[$j]?\n"; prints $list[$i] OK but does not print $spreadsheet[$j]. This line will print both variables correctly on the second and following iterations. I do not see why?
At first glance nothing looks overtly incorrect. As mentioned in the comments the $j = 1 looks questionable but perhaps you are skipping the first row on purpose.
Here is a more perlish starting point that is tested. If it does not work then you have something going on with your input files.
Note the extended trailing whitespace removal. Sometimes if you open a WINDOWS file on a UNIX machine and use chomp, you can have embedded \r in your text that causes weird things to happen to printed output.
#!/usr/bin/perl
use strict; #use warnings;
unless(#ARGV) {
print "\usage: $0 filename\n\n"; # $0 name of the program being executed
exit;
}
my $list = shift;
unless (open(LIST, "<$list")) {
print "\n I can't open your list of genes!!! \n";
exit;
}
open(CHR1, "<acembly_chr_sorted_by_exon_count.txt") or die;
my #spreadsheet = map { s/\s+$//; $_ } <CHR1>;
close CHR1;
# s/\s+$//; is like chomp but trims all trailing whitespace even
# WINDOWS files opened on a UNIX system.
for my $item (<LIST>) {
$item =~ s/\s+$//; # trim all trailing whitespace
print "==> processing '$item'\n";
for my $row (#spreadsheet) {
if ($row =~ /\Q$item\E/) { # see perlre for \Q \E
print "match '$row'\n";
}
else {
print "no match '$row'\n";
}
}
}
close LIST;
I have put together a Perl script to go through a directory and match various keys in the source and output the results to a text file. The match operation works well, however the end goal is to perform a replace operation. The Perl script is as follows:
#!/usr/bin/perl
#use strict;
use warnings;
#use File::Slurp;
#declare variables
my $file = '';
my $verbose = 0;
my $logfile;
my #files = grep {/[.](pas|cmm|ptd|pro)$/i} glob 'C:\users\perry_m\desktop\epic_test\pascal_code\*.*';
#iterate through the files in input directory
foreach $file (#files) {
print "$file\n";
#read the file into a single string
open FILEHANDLE, $file or die $!;
my $string = do { local $/; <FILEHANDLE> };
#perfrom REGEX on this string
########################################################
#fix the include formats to conform to normal PASCAL
$count = 0;
while ($string =~ m/%INCLUDE/g)
{
#%include
$count++;
}
if ($count > 0)
{
print " $count %INCLUDE\n";
}
$count = 0;
while ($string =~ m/INCLUDE/g)
{
#%INCLUDE;
$count++;
}
if ($count > 0)
{
print " $count INCLUDE\n";
}
$count = 0;
while ($string =~ m/(%include\s+')[A-Za-z0-9]+:([A-Za-z0-9]+.[A-Za-z]+')/g)
{
#$1$2;
$count++;
}
if ($count > 0)
{
print " $count XXXX:include \n";
}
}
This produces output as desired, an example is below:
C:\users\perry_m\desktop\epic_test\pascal_code\BRTINIT.PAS
1 INCLUDE
2 XXXX:include
39 external and readonly
However if I change the regex operations to try and implement a replace, using the replacement operation shown in the commented lines above, the scripts hangs and never returns. I imagine it is somehow related to memory, but I am new to Perl. I was also trying to avoid parsing the file by line if possible.
Example:
while ($string =~ s/%INCLUDE/%include/g)
{
#%include
$count++;
}
and
while ($string =~ s/(%include\s+')[A-Za-z0-9]+:([A-Za-z0-9]+.[A-Za-z]+')/$1$2;/g)
{
#$1$2;
$count++;
}
Edit: simplified the examples
The problem is with your while loops. A loop like
while ($string =~ m/INCLUDE/g) { ... }
will execute once for each ocurrence of INCLUDE in the target string, but a subtitution like
$string =~ s/INCLUDE/%INCLUDE;/
will make all of the replacement in one go and retuen the number of replacements made. So a loop
while ($string =~ s/INCLUDE/%INCLUDE;/g) { ... }
will endlessly add more and more percentage signs before and semicolons after every INCLUDE.
To find the number of replacements made, change all your loops like this to just
$count = $string =~ s/INCLUDE/%INCLUDE;/g
the pattern in s/INCLUDE/%INCLUDE/g will match the replacement also, so if you're running it in a while loop it will run forever (until you run out of memory).
s///g will replace all matches in a single shot so you very rarely will need to put it in a loop. Same goes for m//g, it will do the counting in a single step if you put it in list context.