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

Perlmonks Age Stats

by rattusillegitimus (Friar)
on Aug 05, 2002 at 05:37 UTC ( [id://187590]=sourcecode: print w/replies, xml ) Need Help??
Category: PerlMonks Related Scripts
Author/Contact Info rattusillegitimus
Description:

A little while back in the CB, someone (forgive me, I have forgotten who), mentioned it would be interesting to see the age distribution of those monks who have reported their ages for the PerlMonks Stats Pages. So I decided to take a stab at generating such stats.

The script currently pulls up the upcoming birthdays page and scrapes the age information out, then outputs the requested file format (HTML or PNG). A future version might pull XML data from the server instead when it is available.

Examples: HTML Output, Summary Graph, Detail Graph.

Update: T'was dada that proposed the age stats in the CB. Thanks for the reminder ;)
Changed PDF to PNG in the comments.

#!/usr/bin/perl -wT
# $Id: monkages.pl,v 1.3 2002/08/05 05:31:48 corwin Exp $
# 04 Aug 02 - rattusillegitimus of perlmonks.org
#
# Freely redistributable under the same terms as perl itself.
#
# monkages.pl -o HTML > ages.html
#
# monkages.pl -o PNG > summary.png
#
# monkages.pl -o PNG -d > detail.png
#
use strict;
use Getopt::Std;           # Get output type
use LWP::Simple;           # Gather the Data
use HTML::TableExtract;    # Extract the Data
use HTML::Template;        # Build output HTML
use GD::Graph::bars ();    # Build output graph

my $url =
  'http://www.tinymicros.com/pm/index.php?goto=UpcomingBirthdays';
my ( $content, $monks, %agesum, %agedet, $row, %opts );
getopts( 'do:', \%opts );    # Get my command-line options

# Get the page
unless ( defined( $content = get $url) ) {
    die "Could not get $url\n";
}

# Let's do some parsing
my $te =
  new HTML::TableExtract( headers =>
      [ 'Node ID', 'Name', 'Birthday', 'Days Until', 'Current Age' ] )
+;
$te->parse($content);
foreach $row ( $te->rows ) {
    $monks++;
    @$row[4] eq '--' ? $agedet{-1}++ : $agedet{ @$row[4] }++;
    @$row[4] eq '--' ? $agesum{-1}++ : $agesum{ int( @$row[4] / 10 ) }
+++;
}

if ( $opts{'o'} && ( $opts{'o'} eq 'PNG' ) ) {
    my $gd;
    if ( defined $opts{'d'} ) {
        $gd = do_graph( 'D', %agedet );
    }
    else {
        $gd = do_graph( 'S', %agesum );
    }
    print $gd->png;
}
else {
    print do_html( \%agesum, \%agedet );
}

sub do_html {

    # Apply the data to the template
    my ( $agesum, $agedet ) = @_;

    # Build the details array for the template
    my ( @details, @summary );
    for ( sort bynum keys %agedet ) {
        push (
            @details,
            {
                AGE => ( ( $_ == -1 ) ? 'N/A' : $_ ),
                MONKS => $agedet{$_}
            }
        );
    }
    for ( sort bynum keys %agesum ) {
        push (
            @summary,
            {
                AGE => (
                    ( $_ == -1 )
                    ? 'N/A'
                    : sprintf( "%d - %d", $_ * 10, ( $_ * 10 ) + 9 )
                ),
                MONKS => $agesum{$_}
            }
        );
    }
    my $template = HTML::Template->new( filehandle => *DATA );
    $template->param( DETAILS   => [@details] );
    $template->param( SUMMARY   => [@summary] );
    $template->param( MONKCOUNT => $monks );
    return $template->output;
}

sub bynum { $a <=> $b; }    # numeric sorting for great justice

sub age_range {
    my $key = shift;
    return (
        ( $key == -1 )
        ? 'N/A'
        : sprintf( "%d - %d", $key * 10, ( $key * 10 ) + 9 )
    );
}

sub do_graph {

    # Build me a graph using GD::Graph and return the GD image
    my $type    = shift;
    my %agedata = @_;
    my @data;
    for ( sort bynum keys %agedata ) {
        push @{ $data[0] }, ( $type eq 'S' )
          ? age_range($_)
          : ( ( $_ < 0 ) ? 'N/A' : $_ );
        push @{ $data[1] }, $agedata{$_};
    }

    my $graph = new GD::Graph::bars( 600, 400 ) || die "$!";
    $graph->set(
        title            => 'PerlMonks Age Distribution',
        x_label          => ( ( $type eq 'S' ) ? 'Age Range' : 'Age' )
+,
        x_label_position => 1 / 2,
        y_label          => 'Number of Monks',
        shadow_depth     => 3,
        show_values      => 1,
        bar_spacing      => 5,
    );
    return $graph->plot( \@data );
}

__DATA__
<html>
<head>
<title>Perlmonks Age Breakdown</title>
<style type="text/css">
<!--
html { font-family: Verdana; }
body { background-color: #f0f8ff; color: #000000; }
table { border-collapse: collapse; 
        border-style: ridge; 
        background-color: #ccccff; }
th,td { border-style: ridge; }
th { background-color: #cccccc; }
td { text-align: center; }
caption { white-space: nowrap; }
-->
</style>
</head>
<body>
<h1>Perlmonks Age Breakdown</h1>
<h2><TMPL_VAR NAME=MONKCOUNT> monks counted</h2>
<hr/>
<table>
<caption>
<strong>Age Summary</strong>
</caption>
<thead>
<tr>
<th scope="col">Age</th>
<th scope="col"># Monks</th>
</tr>
</thead>
<tbody>
<TMPL_LOOP NAME=SUMMARY>
<tr>
<td>
<TMPL_VAR NAME=AGE>
</td>
<td>
<TMPL_VAR NAME=MONKS>
</td>
</tr>
</TMPL_LOOP>
</tbody>
</table>
<hr/>
<table>
<caption>
<strong>Age Details</strong>
</caption>
<thead>
<tr>
<th scope="col">Age</th>
<th scope="col"># Monks</th>
</tr>
</thead>
<tbody>
<TMPL_LOOP NAME=DETAILS>
<tr>
<td>
<TMPL_VAR NAME=AGE>
</td>
<td>
<TMPL_VAR NAME=MONKS>
</td>
</tr>
</TMPL_LOOP>
</tbody>
</table>
<hr/>
</body>
</html>

Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others chilling in the Monastery: (3)
As of 2025-06-17 01:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?
    erzuuliAnonymous Monks are no longer allowed to use Super Search, due to an excessive use of this resource by robots.