国勢調査の性別×年齢×都道府県の人口分布データを収集するスクリプト

仕事でたまたま聞かれた国勢調査による人口分布に関するデータ。国勢調査の結果は　総務局 - 統計局ホームページ　にて公開されています。最新の国勢調査結果としては　平成17年国勢調査　第１次基本集計結果　が公開されています。基本的に各都道府県別と全国の集計結果がエクセルシートで公開されています。

んがっ、この結果がこれまた非常に見づらいフォーマットのものが多いんですわ。そのままではとても統計データとして利用するに耐えないです。なので整形するスクリプトをでっちあげました。今回のお題目は性別×年齢×都道府県の人口分布データの作成です。

まず元となるデータは４７都道府県別に配布されている　男女・年齢・配偶関係　の総数って統計データを使います。４７都道府県毎のファイルを取得します。URL の形式は

http://www.stat.go.jp/data/kokusei/2005/kihon1/変数（01〜47）/zuhyou/a00411.xls　です。下の赤枠の部分です。

さて・・・賢明な皆様は、この４７個のエクセルファイルをを解析して１つのデータとしてまとめるって、それって全国データじゃん！　・・・と思われるかもしれませんが、

http://www.stat.go.jp/data/kokusei/2005/kihon1/00/zuhyou/a00411.xls

がヘンタイ的なフォーマットになっていて使い物にならないからこういう事をしています。※実際に見て頂くのがはやいかと・・・。

最終的にこんなフォーマットだと見やすいしプログラムからも利用しやすいです。

でっちあげスクリプトはこんな感じ。前述したとおり４７ファイルを取得して整形してマージする。
Spreadsheet::WriteExcel とか Spreadsheet::ParseExcel とか別途インストールしていないと動きません。unicode で保存してくださいね。

## =============================================================================
## 国勢調査結果から　都道府県×年齢×性別　の分布を作成するスクリプト
## =============================================================================
use LWP::Simple;
use Spreadsheet::WriteExcel;
use Spreadsheet::ParseExcel;
use Encode qw/encode decode from_to/;
use utf8;
my $self = {
    srcfile => 'a00411.xls',
    dstfile => 'result.xls',
    pref    => [
        '北海道', '青森県', '岩手県', '宮城県', '秋田県', '山形県', '福島県', '茨城県', '栃木県', '群馬県', '埼玉県', '千葉県', '東京都', '神奈川県', '新潟県', '富山県',
        '石川県', '福井県', '山梨県', '長野県', '岐阜県', '静岡県', '愛知県', '三重県', '滋賀県', '京都府', '大阪府', '兵庫県', '奈良県', '和歌山県', '鳥取県', '島根県',
        '岡山県', '広島県', '山口県', '徳島県', '香川県', '愛媛県', '高知県', '福岡県', '佐賀県', '長崎県', '熊本県', '大分県', '宮崎県', '鹿児島県', '沖縄県'
    ],
};

&get_srcfile($self);
&parse_excel($self);
&print($self);

sub print() {
    my $self = shift;
    my $wkbook = Spreadsheet::WriteExcel->new( $self->{dstfile} );
    my $format = $wkbook->add_format();
    $format->set_font("MS PGothic");
    $format->set_size(10);
    $format->set_border(1);
    my $fmt_bg = $wkbook->add_format();
    $fmt_bg->set_font("MS PGothic");
    $fmt_bg->set_size(10);
    $fmt_bg->set_border(1);
    $fmt_bg->set_bg_color("yellow");

    my $wksheet_m1 = $wkbook->add_worksheet('男性(実数)');
    my $wksheet_f1 = $wkbook->add_worksheet('女性(実数)');
    my $wksheet_m2 = $wkbook->add_worksheet('男性(%)');
    my $wksheet_f2 = $wkbook->add_worksheet('女性(%)');

    my $y       = 0;
    my $x       = 1;
    my $total_m = 0;
    my $total_f = 0;
    for ( @{$self->{data}->{北海道}} ) {
        my $str = ( $_->{age} =~ /\D/ ) ? $_->{age} : $_->{age} . '歳';
        $wksheet_m1->write( $y, $x, $str, $fmt_bg );
        $wksheet_f1->write( $y, $x, $str, $fmt_bg );
        $wksheet_m2->write( $y, $x, $str, $fmt_bg );
        $wksheet_f2->write( $y, $x, $str, $fmt_bg );
        $x++;
    }
    ## 実数
    for my $pref ( @{$self->{pref}} ) {
        $y++;
        $x = 0;
        my $data   = $self->{data}->{$pref};

        $wksheet_m1->write( $y, $x, $pref, $fmt_bg );
        $wksheet_f1->write( $y, $x, $pref, $fmt_bg );
        $wksheet_m2->write( $y, $x, $pref, $fmt_bg );
        $wksheet_f2->write( $y, $x, $pref, $fmt_bg );
        $x++;
        for ( @$data ) {
            my $male   = $_->{male};
            my $female = $_->{female};
            $wksheet_m1->write( $y, $x, $male, $format );
            $wksheet_f1->write( $y, $x, $female, $format );
            if ( $_->{age} ne '不詳' ) {
                $total_m += $male;
                $total_f += $female;
            }
            $x++;
        }
    }
    ## ％
    $y = 0;
    for my $pref ( @{$self->{pref}} ) {
        $y++;
        $x = 1;
        my $data   = $self->{data}->{$pref};
        for ( @$data ) {
            my $male   = $_->{male};
            my $female = $_->{female};
            $wksheet_m2->write( $y, $x, (100*$male)/$total_m, $format );
            $wksheet_f2->write( $y, $x, (100*$female)/$total_f, $format );
            $x++;
        }
    }
    $wkbook->close;
}

sub get_srcfile() {
    my $self = shift;
    my $i = 1;
    mkdir "./src" unless ( -e "./src" );
    for my $pref ( @{$self->{pref}} ) {
        my $sjisname = encode('sjis', $pref);
        my $idx = ($i<10) ? qq{0$i} : $i;
        my $file = qq{./src/$sjisname-$self->{srcfile}};
        unless ( -e $file ) {
            my $src = get(qq{http://www.stat.go.jp/data/kokusei/2005/kihon1/$idx/zuhyou/a00411.xls}) or die qq{can not connect: $!};
            open my $fh, '>', $file or die $!;
            binmode $fh;
            print $fh $src;
            close $fh;
        }
        $i++;
    }
}

sub parse_excel() {
    my $self = shift;
    my $i = 1;
    for my $pref ( @{$self->{pref}} ) {
        my $sjisname = encode('sjis', $pref);
        my $idx = ($i<10) ? qq{0$i} : $i;
        my $file = qq{./src/$sjisname-$self->{srcfile}};
        warn qq{$file\n};

        my $oExcel = Spreadsheet::ParseExcel->new;
        my $oBook  = $oExcel->Parse($file);
        my $sheet  = $oBook->{Worksheet}->[0];
        $self->{data}->{$pref} = [];
        my $data = $self->{data}->{$pref};
        for ( 14 .. 130 ) {
            my $age    = $sheet->{Cells}[$_][2]->Value;
            my $male   = $sheet->{Cells}[$_][6]->Value;
            my $female = $sheet->{Cells}[$_][7]->Value;
            $age    =~ s/\xe3\x80\x80//g;
            $age    =~ s/\s//g;
            $male   =~ s/\D//g;
            $female =~ s/\D//g;
            push @$data, { age => $age, male => $male, female => $female };
        }
        $i++;
    }
}

最終的にこんなファイルが生成されます。スクリプトが動作しない方はこちらをご自由にどうぞ。→ result.xls