view release on metacpan or  search on metacpan

exec/nextool.pl  view on Meta::CPAN

    my ($nexus, @blocks) = @_;
    return $nexus->select_blocks(\@blocks);
}

# select subset of OTUs 
sub selectbyotu {
    my ($nexus, $mode, @args) = @_;
    die "need otu names" unless (@args);
    my @otus;
    if ($args[0] eq '-f') { # input from file
        my $file = $args[1];
        open(FILE, $file) or carp "File $file not found\n";
        my @lines = <FILE>;
        @otus = split /\s+/, "@lines";
        close(FILE);
    }else {   # input from command line separated by space
        my $list = join( " ", @args ); 
        $list = unquote( $list ); 
        $list =~ s/^\s+|\s+$//g; 
        @otus = split( /[,\s]\s*/, $list ); 
    }
    if ( $mode == 1 ) { # select mode 
        return $nexus->select_otus(\@otus); 
    }
    else { # exclude mode 
        return $nexus->exclude_otus(\@otus); 
    }
}

# select a tree
sub selectbytree {
    my ($nexus, $treename) = @_;
    ($treename) or die "ERROR: Need to specify a tree to be selected\n";
    return $nexus->select_tree($treename);
}

# select a subtree
sub selectbyinode {
    my ($nexus, $nodename, $treename) = @_;
    $nodename or die "ERROR: Need to specify an internal node for subtree\n";
    
    return $nexus->select_subtree($nodename, $treename);
}

# use $command=1 for select and $command=0 for exclude
# arguments (column numbers) can be of form: 
# 1) 1-3 4 5 6-10 or 1-3, 4  5, 6-10
# 2) -f <file name> contains numbers in format as examplified in 1)  
sub selectbycolumn {
    my ($nexus, $command, @args) = @_;
    my $args = "@args";
    $args =~ s/title\s*=\s*(\w+)//i;    
    my $title = $1;
#    my $block = $nexus->get_block("characters", $title);
    
    die "need column numbers" unless $args;
    
    my $columns;
    if ($args =~ /-f (\S+)/) { # input from file
        my $file = $1;
        $columns = do{ local(@ARGV, $/) = $file; <>};
        $columns =~ s/\n/ /g;
    }else {   # input from command line separated by comma or space
        $columns = $args;
    }
    
    my @columns = @{ &parse_number($columns) };
    if ($command) {
        return $nexus->select_chars(\@columns, $title);
    }else {
        return $nexus->exclude_chars(\@columns, $title);
    }
}

sub selectbysets {
    my ($nexus, $mode, @setnames) = @_;    
    my @otus;
    die "Provide set names as arguments\n" unless (@setnames);
    for my $setname (@setnames) {
        push(@otus, @{ $nexus->get_block('sets')->get_taxset($setname) } );
    }

    if ( $mode == 1 ) { # "select" mode 
        return $nexus->select_otus(\@otus); 
    } else { # "exclude" mode 
        return $nexus->exclude_otus(\@otus); 
    }
}

# parse numbers in format "1-3, 4 6 8-10"
sub parse_number {
    my $s = unquote( shift );
    
    if (! $s =~ /^\s*(\d+(-\d+)?)([,\s]\s*\d+(-\d+)?)*\s*$/ ) { 
        die "Invalid number format.  Use 1 or 1-3 or 1, 3, 5-8 or 1 3 5 6-10.\n"; 
    } 
    $s =~ s/^\s+|\s+$//g;
    $s =~ s/,?\s+/,/g;  # use ',' as separator
    my @cols = split(/,/, $s);
    
    my @arr;
    foreach my $item (@cols) {
        if ($item =~ /-/) { # eg 1-3
            $item =~ /([0-9]+)\s*-\s*([0-9]+)/;
            for (my $i = $1; $i <= $2; $i++) { push ( @arr, $i-1 ); }
        } elsif ($item =~ /^\d+$/) { # eg 4
            push ( @arr, $item-1 );
        } elsif ($item) {
            die "non-number was used for column number\n";
        }
    }

    @arr = sort {$a<=>$b} @arr;
    return \@arr;
}

sub unquote { 
    my $string = shift; 
    $string =~ s/^ *'(.*)' *$/$1/;
    $string =~ s/^ *"(.*)" *$/$1/;
    return( $string );