#!/usr/bin/perl -w
#
# This is a modified version of motifmaker. It runs significantly faster,
#   accepts command line parameters and compiles well with the -w perl
#   switch. Some error reporting has been improved.
#
# NOTE: Some of the functionality of the old version may not be implemented yet!
#


use FindBin;
use lib "$FindBin::Bin";

use motifmaker;
use English;
use Alignments;
use color;

$SUFFIX_GPRF  = 'gprf';
$SUFFIX_PRF   = 'prf';
$SUFFIX_LIST  = 'list';
$SUFFIX_SLIST = 'slist';
$SUFFIX_NLIST = 'nlist';
$SUFFIX_HLIST = 'hlist';
$SUFFIX_SCHM  = 'schm';
$SUFFIX_HTML  = 'html';
$SUFFIX_INC   = 'inc';
$vectorlib    = 'vectorlib-swissprot-56.0.pm';

# These parameters are command-line editable.
$html_params = 
{
    'head'   => 1,      # If unchecked, also the HTML '.inc' file will be created.
    'ncols'  => 50,
    'e1'     => 1,
    'e2'     => 1,
    'e3'     => 1,
    'e4'     => 1,
    'e5'     => 1,
    'schm'   => 1,
};

parse_cmd_line_args();
$global_prf = create_global_profile($alignment_file,$consensus);

if ( $variable_entropy )
{
    define_motifs_variable($global_prf,$variable_entropy,$max_gap_length,$min_motif_length);
}
if ( $fixed_entropy )
{
    define_motifs_fixed($global_prf,$fixed_entropy,$max_gap_length,$min_motif_length);
}
create_html_output($global_prf,$html_params);
if ( !$html_params->{'head'} )
{
    # This could be done better, e.g. by printing the header separately
    #   and concatenating. But this is not a critical step, may change
    #   later...
    #
    `cp $prefix.$SUFFIX_HTML $prefix.$SUFFIX_INC`;
    $html_params->{'head'} = 1;
    create_html_output($global_prf,$html_params);
}

exit;

#--------------------------


sub parse_cmd_line_args
{
    $cmd_args = join(' ',@ARGV);
    my $total_entropy_method = 'unscaled_sum';

    $substitute = '';
    $consensus  = '';
    $motifmaker::include_gaps = 0;
    while (my $arg=shift(@ARGV))
    {
        if ( $arg eq '-V' || $arg eq '--vector-lib' ) { $vectorlib=shift(@ARGV); next; }
        if ( $arg eq '-a' || $arg eq '--alignment' ) { $alignment_file=shift(@ARGV); next; }
        if ( $arg eq '-p' || $arg eq '--prefix' ) { $prefix=shift(@ARGV); next; } 
        if ( $arg eq '-f' || $arg eq '--fixed-entropy' ) { $fixed_entropy=shift(@ARGV); next; } 
        if ( $arg eq '-g' || $arg eq '--gap-length' ) { $max_gap_length=shift(@ARGV); next; } 
        if ( $arg eq '-l' || $arg eq '--motif-length' ) { $min_motif_length=shift(@ARGV); next; } 
        if ( $arg eq '-c' || $arg eq '--consensus-sequence' ) { $consensus=shift(@ARGV); next; }
        if ( $arg eq '-S' || $arg eq '--scaled-sum' ) { $total_entropy_method = 'scaled_sum'; next; }
        if ( $arg eq '-u' || $arg eq '--unscaled-sum' ) { $total_entropy_method = 'unscaled_sum'; next; }
        if ( $arg eq '-m' || $arg eq '--unscaled-max' ) { $total_entropy_method = 'unscaled_max'; next; }
        if ( $arg eq '-o' || $arg eq '--original-approach' ) { $total_entropy_method = 'ori'; next; }
        if ( $arg eq '-i' || $arg eq '--include-gaps' ) { $motifmaker::include_gaps=1; next; }
        if ( $arg eq '-t' || $arg eq '--motif-type' ) 
        { 
            my $tmp = shift(@ARGV);
            if ( $tmp eq 'signif' ) { $motifmaker::motif_type = $motifmaker::significant_motifs }
            elsif ( $tmp eq 'simil' ) { $motifmaker::motif_type = $motifmaker::similar_motifs }
            else { usage("The motif type \"$tmp\" not recognised.\n") }
            next; 
        }
        if ( $arg eq '-H' || $arg eq '--html-params' ) 
        { 
            my $params = shift(@ARGV);
            my @items  = split(/,/,$params);
            for my $item (@items)
            {
                my ($key,$value) = split(/=/,$item);
                $html_params->{$key} = $value;
            }
            next; 
        }
        if ( $arg eq '-n' || $arg eq '--use-old-names' ) 
        { 
            $SUFFIX_GPRF  = 'PCPgprf';
            $SUFFIX_PRF   = 'PCPprf';
            $SUFFIX_SLIST = 'PCPSlist';
            $SUFFIX_NLIST = 'PCPNlist';
            $SUFFIX_SCHM  = 'PCPschm';
            next; 
        } 
        if ( $arg eq '-v' || $arg eq '--var-entropy' ) { $variable_entropy=shift(@ARGV); next; }
        if ( $arg eq '-?' || $arg eq '-h' || $arg eq '--help' ) { usage(); } 
        if ( $arg eq '-s' || $arg eq '--substitute' ) { $substitute=shift(@ARGV); next; }
        usage("Unknown option: \"$arg\". (Use -h option for help.)\n");
    }

    if ( !$alignment_file ) { usage("Expected the -a option.\n"); }
    if ( !-e $alignment_file ) { usage("No such file: $alignment_file\n"); }

    if ( ! defined $max_gap_length) { usage("Missing the -g option.\n"); }
    if ( ! defined $min_motif_length) { usage("Missing the -m option.\n"); }
    if ( !$variable_entropy && !$fixed_entropy ) { usage("Expected the -v or -f option.\n") }

    require $vectorlib;
    require utils;
    Alignments::select_total_entropy_method($total_entropy_method);

    $prefix = Utils::init_result_dir($prefix);

    open(LOG,">>$prefix.log") || usage("$prefix.log: $!");
    print LOG "motifmaker args: $cmd_args\n";
    close(LOG);

    `cp $alignment_file $prefix.aln` unless -e "$prefix.aln";
}

sub usage
{
    my (@msg) = @_;
    if ( scalar @msg )
    {
        print STDERR join('',@msg);
        exit -1;
    }

    print STDERR 
        "Options:\n",
        "   -a,  --alignment <file>                     Input file with multiple alignments.\n",
        "   -c,  --consensus-sequence <string>          Which of the sequences should be the consensus (reference) sequence.\n",
        "   -f,  --fixed-entropy <float>                Use fixed relative entropy cutoff. Use values between 2.0-3.0 for highly\n",
        "                                                   conserved sequences or 0.75-2.0 for moderately conserved ones.\n",
        "   -H,  --html-params <string>                 HTML parameters, for example 'ncols=50,head=0', etc. See the \$html_params variable for more.\n",
        "   -g,  --gap-length <int>                     Maximal length of gaps: 0-1 for highly conserved, 2-4 for moderately conserved.\n",
        "   -i,  --include-gaps                         Include also positions where there is a gap in the consensus sequence.\n",
        "   -l,  --motif-length <int>                   Number of conserved residues in motifs: 4-7 for highly conserved, 2-4 for moderately conserved.\n",
        "   -m,  --unscaled-max                         Use the unscaled-maximum approach.\n",
        "   -n,  --use-old-names                        Use this switch to get the old naming scheme (e.g. xxx.PCPgprf).\n",
        "   -o,  --original-approach                    Intended for backward-compatibility tests only.\n",
        "   -p,  --prefix <string>                      Prefix of the output files.\n",
        "   -S,  --scaled-sum                           Use the scaled-sum approach.\n",
        "   -s,  --substitute <list>                    If the alignment file contains letters which are not permitted, such as 'X',\n",
        "                                                   for example, replace the letter. The format is a comma separated list of\n",
        "                                                   expressions ORI:NEW. (For example 'X:-,.:-,\\ :-,*:-')\n",
        "   -t,  --motif-type <signif|simil>            Create SIGNIFICANT or CONSERVED residues motifs?\n",
        "   -u,  --unscaled-sum                         Use the unscaled-sum approach. (This is the default.)\n",
        "   -v,  --var-entropy <min>,<max>,<step>       Use variable relative entropy range.\n",
        "   -V,  --vector-lib <file>                    Use the specified vectorlib.pm (see also create-vectorlib)\n",
        "\n";
    exit -1;
}


sub create_global_profile
{
    my ($alignment_file,$consensus) = @_;

    my ($alignment) = Alignments::parse_alignment($alignment_file,{'substitute'=>$substitute});
    Alignments::check_alignment_sanity($alignment);
    if ( $consensus )
    {
        # If a some sequence is requested to be taken as the consensus sequence,
        #   change the order so that this sequence is the first one in the @$alignent array.
        #
        my $cons_seq_idx = Alignments::get_sequence_index($alignment,$consensus);
        if ( scalar @$cons_seq_idx == 0 ) 
        { 
            my @seqs = ();
            for my $seq (@$alignment) { push @seqs,$$seq{id}; }
            usage(
                    "No such sequence '$consensus' in the alignment $alignment_file.\n",
                    "The alignment contains the following sequences:\n\t", join(",\n\t",@seqs), "\n"
                 ) ;
        }
        if ( scalar @$cons_seq_idx > 1 ) 
        {
            my @seqs = ();
            for my $idx (@$cons_seq_idx) { push @seqs,$$alignment[$idx]{id} }
            usage(
                    "There are multiple sequences in the alignment matching the string \"$consensus\".\n",
                    "The list of matching sequences:\n\t", join(",\n\t",@seqs), "\n"
                 );
        }

        my $tmp = $$alignment[$$cons_seq_idx[0]];
        $$alignment[$$cons_seq_idx[0]] = $$alignment[0];
        $$alignment[0] = $tmp;
    }

    my $tmp = Alignments::get_least_alignment_entropies($alignment_file,$alignment);
    my @least_entrps = @$tmp;
    # Sanity check
    if ( scalar @least_entrps && scalar @least_entrps != length($$alignment[0]->{seq}) ) 
    { 
        usage(
                "Sanity check failed: The alignment has different length than the corresponding .entrps file.\n",
                length($$alignment[0]->{seq}), " vs. ", scalar @least_entrps, "\n"
             ); 
    }

    $tmp = Alignments::get_least_alignment_similarities($alignment_file,$alignment);
    my @least_smls = @$tmp;
    # Sanity check
    if ( scalar @least_smls && scalar @least_smls != length($$alignment[0]->{seq}) ) 
    { 
        usage(
                "Sanity check failed: The alignment has different length than the corresponding .smls file.\n",
                length($$alignment[0]->{seq}), " vs. ", scalar @least_smls, "\n"
             ); 
    }

    my $global_prf = &makeprofile($alignment,\@least_entrps,\@least_smls);

    open(OUT,">$prefix.$SUFFIX_GPRF") || usage("$prefix.$SUFFIX_GPRF: $!\n");
    for my $prf (@$global_prf)
    {
        Utils::print_profile_line(\*OUT, $prf);
    }
    close(OUT);

    return $global_prf;
}


sub define_motifs_fixed
{
    my ($global_prf,$fixed_entropy,$max_gap_length,$min_motif_length) = @_;

    my ($info,$motifs) = fullprofile2motif($global_prf,$fixed_entropy,$max_gap_length,$min_motif_length);

    print_nlist("$prefix.$SUFFIX_NLIST", $cmd_args, $motifs);

    Utils::print_profile("$prefix.$SUFFIX_PRF", $cmd_args, $motifs, $global_prf);
    print_slist("$prefix.$SUFFIX_SLIST", $cmd_args, $motifs, $global_prf);
    print_list("$prefix.$SUFFIX_LIST", $motifs);

    open(OUT,">$prefix.$SUFFIX_HLIST") || usage("$prefix.$SUFFIX_HLIST: $!\n");
    print_html_motifs(\*OUT, {checkboxes=>1});
    close(OUT);
}


sub print_nlist
{
    my ($fname,$info,$motifs) = @_;

    open(OUT,">$fname") || usage("$fname: $!\n");
    print OUT "# $info\n";
    foreach my $motif (@$motifs)
    {
        print OUT join('*',@{$$motif{'motif'}}), "\n";
    }
    close(OUT);
}


sub print_slist
{
    my ($fname,$info,$motifs,$global_prf) = @_;

    open(OUT,">$fname") or usage("$fname: $!\n");
    print OUT "# $cmd_args\n";

    #   print OUT "#MOTIF :  0:   ",join('*',@{$$motifs[$#$motifs]}),"\n";  # The stray motif goes first, but is the last one
    #                                                                       #   in the list of motifs.
    #                                                                       # BTW, no idea what is this good for.

    for (my $i=0; $i<scalar @$motifs; $i++)
    {
        my @motif = @{$$motifs[$i]->{'motif'}};
        printf OUT "#MOTIF %3d: %.2f : %4d ", $i,$$motifs[$i]->{'R'},$$global_prf[$motif[0]-1]->{'ref_idx'};
        
        for (my $j=0; $j<scalar @motif; $j++)
        {
            # The motifs contain holes (non-significant residues). They must be filled.
            
            my ($pos_j,$pos_j1);
            
            $pos_j  = $motif[$j];
            
            if ( $j==$#motif ) 
            {
                print OUT $$global_prf[$pos_j-1]->{'reference'};
            }
            else
            {
                $pos_j1 = $motif[$j+1];
                for (my $pos=$pos_j; $pos<$pos_j1; $pos++)
                {
                    print OUT $$global_prf[$pos-1]->{'reference'};
                }
            }
        }
        print OUT " ",$$global_prf[$motif[$#motif]-1]->{'ref_idx'},"\n";
    }
    close(OUT);
}


# Similar to print_slist, but the missing non-significant positions are replaced by dots.
sub print_list
{
    my ($fname,$motifs) = @_;
    open(OUT,">$fname") or usage("$fname: $!\n");
    for (my $i=0; $i<scalar @$motifs; $i++)
    {
        my @motif = @{$$motifs[$i]->{'motif'}}; #@{$$motifs[$i-1]};  # skip the stray motif
        my $prev_pos;
        for (my $j=0; $j<scalar @motif; $j++)
        {
            my $pos = $motif[$j];
            if ( $j==0 || $prev_pos+1==$pos )
            {
                print OUT $$global_prf[$pos-1]->{'reference'};
                $prev_pos = $pos;
                next;
            }
            
            for (my $k=$prev_pos+1; $k<$pos; $k++)
            {
                print OUT '.';
            }
            print OUT $$global_prf[$pos-1]->{'reference'};
            $prev_pos = $pos;
        }
        print OUT "\n";
    }
    close(OUT);
}


sub define_motifs_variable
{
    my ($global_prf,$variable_entropy,$max_gap_length,$min_motif_length) = @_;

    my ($entropy_from,$entropy_to,$entropy_step) = split(/,/,$variable_entropy);

    my ($info,$motifs,$scheme) = &IterateR($global_prf,$entropy_from,$entropy_to,$entropy_step,$max_gap_length,$min_motif_length);
    open(OUT,">$prefix.$SUFFIX_SCHM") || usage("$prefix.$SUFFIX_SCHM: $!");
    print OUT join("\n",@$scheme);
    close(OUT);

    print_nlist("$prefix.$SUFFIX_NLIST",$cmd_args, $motifs);

    Utils::print_profile("$prefix.$SUFFIX_PRF", $cmd_args, $motifs, $global_prf);
    print_slist("$prefix.$SUFFIX_SLIST", $cmd_args, $motifs, $global_prf);
    print_list("$prefix.$SUFFIX_LIST", $motifs);

    open(OUT,">$prefix.$SUFFIX_HLIST") || usage("$prefix.$SUFFIX_HLIST: $!\n");
    print_html_motifs(\*OUT, {checkboxes=>1});
    close(OUT);
}


sub read_schm_data
{
    my ($file) = @_;

    my @schm_data = ();
    my $conserved = '';

    if ( ! -e $file ) { return ($conserved,\@schm_data); }

    open(FILE,"<$file") || usage("$file: $!\n");
    for (1..4) { <FILE> }

    my $padlen = 0;
    while (my $line=<FILE>)
    {
        chomp($line);

        if ( $line=~/^(\S+)(\s+)(\S+)/ ) 
        { 
            push @schm_data, { entropy=>$1, line=>$3 };
            $padlen = length($1) + length($2);
            next;
        }
        $conserved = substr($line, $padlen);
        last;
    }
    close(FILE);

    return ($conserved,\@schm_data);
}


sub read_nlist_file
{
    my ($file) = @_;
    my $motifs = {};

    if ( ! -e $file ) { return $motifs; }
    open(MOTIFS,"<$file") || usage("$file: $!\n");
    my @lines = <MOTIFS>;
    close(MOTIFS);
    for (my $iline=1; $iline<scalar @lines; $iline++)
    {
        my $line = $lines[$iline];
        chomp($line);
        my @items = split(/\*/,$line);
        for (my $i=$items[0]; $i<=$items[$#items]; $i++)
        {
            $motifs->{$i-1} = 1;
        }
    }
    return $motifs;
}


sub profile_get_max_dev
{
    my ($prf) = @_;
    my $max;
    for my $column (@$prf)
    {
        for my $dev (@{$$column{'devs'}})
        {
            if ( !$max ) { $max=$dev }
            if ( $max<$dev ) { $max=$dev; }
        }
    }
    return $max;
}


sub create_html_output
{
    my ($global_prf,$params) = @_;

    # The original entropies are not scaled to interval 0-1, the coloring would be wrong.
    if ( $Alignments::total_entropy_approach eq 'ori' ) 
    { 
        print STDERR "The create_html_output is not implemented for the 'ori' total entropy method.\n";
        return; 
    }

    my $max_dev = profile_get_max_dev($global_prf);

    my ($conserved,$schm_data) = read_schm_data("$prefix.$SUFFIX_SCHM");
    my $motifs = read_nlist_file("$prefix.$SUFFIX_NLIST");

    if ( !$params->{'schm'} ) { @$schm_data = (); }

    open(HTML,">$prefix.$SUFFIX_HTML") || usage("$prefix.$SUFFIX_HTML: $!\n");

    if ( $params->{'head'} )
    {
        print HTML << "EOT";
<HTML>
<head>
    <style>
        div.mmaker_params { padding-top: 1em; padding-bottom:1em; border-bottom: solid black 1px; }
        .mmaker_params  table { margin-left: 1em; } 
        table.mmaker_results
        {
            padding: 0em;
            margin: 0em;
            text-align: center;
            border-collapse: collapse;
        }
        .mmaker_results td
        {
            padding-left: 0.2em;
            padding-right: 0.2em;
            margin: 0em;
            border: solid 1px #bbbbbb;
            font-family: monospace;
            font-size: 8pt;
        }
        .mmaker_results .motif { background-color: #cccccc; }
        table.motif_table
        {
            padding: 0;
            margin: 0;
            margin-right: 1em;
            border-collapse: collapse; 
            display: inline;
        }
        .motif_table td 
        { 
            padding: 0px; 
            padding-left:1px; 
            padding-right:1px; 
            margin: 0px; 
            text-align:center; 
            font-family: monospace; 
            font-size: 8pt;
            border: solid 1px #bbbbbb;
        }
        table.aln 
        { 
            padding: 0px; 
            margin: 0px; 
            border-collapse: collapse; 
            margin-bottom: 2em;
        }
        .aln td 
        { 
            padding: 0px; 
            padding-left:1px; 
            padding-right:1px; 
            margin: 0px; 
            text-align:center; 
            font-family: monospace; 
            font-size: 8pt; 
        }
        div.aln
        {
            padding-left: 2em;
            padding-top: 0.1em;
            padding-bottom: 0.5em;
            font-family: monospace;
            font-size: 8pt;
        }
        div.aln > span
        {
            padding: 1px;
            font-family: monospace;
            font-size: 8pt;
        }
        .aa_A { background-color: #c8c251; }
        .aa_C { background-color: #73c851; }
        .aa_D { background-color: #e96f6c; }
        .aa_E { background-color: #e96f6c; }
        .aa_F { background-color: #c8c251; }
        .aa_G { background-color: #73c851; }
        .aa_H { background-color: #9ca7de; }
        .aa_I { background-color: #c8c251; }
        .aa_K { background-color: #9ca7de; }
        .aa_L { background-color: #c8c251; }
        .aa_M { background-color: #c8c251; }
        .aa_N { background-color: #73c851; }
        .aa_P { background-color: #c8c251; }
        .aa_Q { background-color: #73c851; }
        .aa_R { background-color: #9ca7de; }
        .aa_S { background-color: #73c851; }
        .aa_T { background-color: #73c851; }
        .aa_V { background-color: #c8c251; }
        .aa_W { background-color: #c8c251; }
        .aa_Y { background-color: #73c851; }
    </style>
</head>
<body>
EOT
    }


    print HTML "<div class='mmaker_params'><table class='aln'>\n";
    my $idx = 0;
    while ( $idx<scalar @$global_prf )
    {
        if ( $idx % $$params{'ncols'} == 0 ) 
        { 
            if ( $idx!=0 ) 
            {
                print HTML "<td style='font-size:x-small; padding-left:1em;'>$idx";
            }
            print HTML "<tr><td style='font-size:x-small; padding-right: 1em;'>" . ($idx+1); 
        }

        my $aa  = $$global_prf[$idx]->{'reference'};
        my $pos = ( $aa eq '-' ) ? '-' : $$global_prf[$idx]->{ref_idx};
        $pos   .= " / ". $$global_prf[$idx]->{aln_column};

        my @style = ();
        if ( exists($motifs->{$idx}) ) 
        { 
            push @style, "border-bottom: solid 1px black; border-top: solid 1px black; font-weight: bold; ";
            push @style, "border-top: solid 1px black;";

            if ( !exists($motifs->{$idx+1}) )
            {
                push @style, "border-right: solid 1px black;";
            }
            if ( !exists($motifs->{$idx-1}) )
            {
                push @style, "border-left: solid 1px black;";
            }
        }
         
        my $style = scalar @style ? 'style="'.join('',@style).'"' : '';

        print HTML "<td title='$pos' $style class='aa_$aa'>$aa";

        $idx++;
    }
    while ($idx % $$params{'ncols'} != 0)
    {
        print HTML "<td>";
        $idx++;
    }
    print HTML "</table></div>\n\n";


    print HTML "<div class='mmaker_params'><a name='motifs'></a><b>Motifs</b> (only significant positions shown):<P>\n";
    print_html_motifs(\*HTML);
    print HTML "</div>\n";
    
    print HTML "<div class='mmaker_params'><a name='detailed'></a><b>Detailed output:</b><br>\n";
 
    my $ipos = 0;
    while ( $ipos<scalar @$global_prf )
    {
        print HTML "<br>\n";
        print HTML "<table class='mmaker_results'>\n";

        print HTML "<tr><td>Motifs";
        for (my $icol=0; $icol<$params->{ncols}; $icol++)
        {
            my $idx = $ipos + $icol;
            if ( $idx >= scalar @$global_prf ) { last }

            my $style = exists($motifs->{$idx}) ? "class='motif'" : '';

            my $cons = '';
            if ( $conserved ) { $cons = substr($conserved,$idx,1); }

            printf HTML "<td $style>$cons";
        }
        print HTML "<td style='border:none'>\n";

        # Reference sequence 
        print HTML "<tr><td>Reference";
        my $pos;
        for (my $icol=0; $icol<$params->{ncols}; $icol++)
        {
            my $idx = $ipos + $icol;
            if ( $idx >= scalar @$global_prf ) { last }

            my $aa  = $$global_prf[$idx]->{'reference'};
            $pos  = ( $aa eq '-' ) ? '-' : $$global_prf[$idx]->{ref_idx};
            $pos .= "/". $$global_prf[$idx]->{aln_column};

            print HTML "<td title='$pos'>$aa";
        }
        print HTML "<td style='border:none; font-size: x-small; padding-left: 1em;'>$pos\n";

        # Similarity
        print HTML "<tr><td>Similarity";
        for (my $icol=0; $icol<$params->{ncols}; $icol++)
        {
            my $idx = $ipos + $icol;
            if ( $idx >= scalar @$global_prf ) { last }

            my $color = Color::get_color_string("ff4444","ffffff","669966", $$global_prf[$idx]->{similarity});
            printf HTML "<td title='%.3f' style='background-color:$color;'>",$$global_prf[$idx]->{similarity};
        }
        print HTML "<td style='border:none'>\n";

        # Deviations
        for my $prop (1..$Vectorlib::nprops)
        {
            print HTML "<tr><td>D$prop";
            for (my $icol=0; $icol<$params->{ncols}; $icol++)
            {
                my $idx = $ipos + $icol;
                if ( $idx >= scalar @$global_prf ) { last }

                # The parameter 0.2 below is purely empirical to give visually pleasing results.
                #   May be changed in the future. Tested for Flavivirus NS3 protein.
                my $devs  = $$global_prf[$idx]->{devs};
                my $dev   = $$devs[$prop-1]==-1 ? 0 : exp(-$$devs[$prop-1]*0.2);  
                my $color = Color::get_color_string("ffffff","ffffff","888888", $dev);

                printf HTML "<td title='%.3f' style='background-color:$color;'>",$$devs[$prop-1];
            }
            print HTML "<td style='border:none'>\n";
        }

        # Total entropy
        print HTML "<tr><td>Total E";
        for (my $icol=0; $icol<$params->{ncols}; $icol++)
        {
            my $idx = $ipos + $icol;
            if ( $idx >= scalar @$global_prf ) { last }

            my $aa    = $$global_prf[$idx]->{'reference'};
            my $entrp = $$global_prf[$idx]->{'total_entrp'};
            my $color = $entrp < 0 ? "#ff4444" : Color::get_color_string("ff4444","ffffff","5555ff", $entrp);

            printf HTML "<td title='%.3f' style='background-color:$color;'>",$entrp;
        }
        print HTML "<td style='border:none'>\n";


        # Relative entropies
        for my $prop (1..$Vectorlib::nprops)
        {
            print HTML "<tr><td>E$prop";
            for (my $icol=0; $icol<$params->{ncols}; $icol++)
            {
                my $idx = $ipos + $icol;
                if ( $idx >= scalar @$global_prf ) { last }

                my $entrps = $$global_prf[$idx]->{entrps};
                my $entrp  = $$entrps[$prop-1];
                my $color  = $entrp < 0 ? "#ffffff" : Color::get_color_string("ffffff","888888","000000", $entrp);

                printf HTML "<td title='%.3f' style='background-color:$color;'>",$entrp;
            }
            print HTML "<td style='border:none'>\n";
        }

    
        # Output at most one empty line of the schm file.
        for (my $ientrp=0; $ientrp<scalar @$schm_data; $ientrp++)
        {
            my $out = "<tr><td>".$$schm_data[$ientrp]->{entropy};
            my $empty = 1;
            for (my $icol=0; $icol<$params->{ncols}; $icol++)
            {
                my $idx = $ipos + $icol;
                if ( $idx >= scalar @$global_prf ) { last }

                my $aa = substr($$schm_data[$ientrp]->{line},$idx,1);
                if ( $aa eq '-' ) { $aa = '' }
                else { $empty=0; }

                $out .= "<td>$aa";
            }
            print HTML $out, "<td style='border:none'>\n";
            if ( $empty ) { last }
        }
        print HTML "</table>\n";

        $ipos += $params->{ncols};
    }
    print HTML "</div>\n";

    my @hist = ();
    my $c = $Vectorlib::created_from; $c = $Vectorlib::bins; # to keep compiler happy
    for my $aa (sort keys %$Vectorlib::histogram)
    {
        push @hist, sprintf " $aa&nbsp;%.3f%%", $Vectorlib::histogram->{$aa};
    }
    print HTML 
        "<div class='mmaker_params'>This calculation was based on the background\n",
        "probability distribution created for $Vectorlib::nbins bins from $Vectorlib::created_from residues:\n",
        "<div style='margin:0px;padding:0px;margin-left:2em;'>\n",
        join(', ',@hist),"\n",
        "</div>\n",
        "Distribution of amino acids into bins:\n",
        "<table>\n";
    for my $prop (1..$Vectorlib::nprops)
    {
        print HTML "<tr><td>E$prop ...";
        for my $bin (1..$Vectorlib::nbins)
        {
            my $aas = $Vectorlib::bins->{$prop}->{$bin};
            print HTML "<td style='padding-left:0.5em'>", join(',',sort @$aas);
        }
        print HTML "\n";
    }
    print HTML "</table></div>\n";

    close(HTML);
}


sub print_html_motifs
{
    my ($fh,$options) = @_;
    
    # The original entropies are not scaled to interval 0-1, the coloring would be wrong.
    if ( $Alignments::total_entropy_approach eq 'ori' ) 
    { 
        print STDERR "The create_html_output is not implemented for the 'ori' total entropy method.\n";
        return; 
    }

    my $motifs = Utils::read_prf_file_motifs("$prefix.$SUFFIX_PRF");
    my $out = Utils::format_html_motif_tables($motifs,$options);
    print $fh $out;
}

