Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Perlmonks Age Stats

by rattusillegitimus (Friar)
on Aug 05, 2002 at 05:37 UTC ( #187590=sourcecode: print w/ replies, xml ) Need Help??

Category: Perlmonks.org 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>

Comment on Perlmonks Age Stats
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others scrutinizing the Monastery: (11)
As of 2014-07-23 08:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (136 votes), past polls