use strict; use warnings; # - - - - - - - - - - - - - - - - - - - - - - - - - - # e.g. if 'ibm' queried, script writes to files: # ibm.html ibmdiff.jpg ibmlog.jpg ibm.csv # - - - - - - - - - - - - - - - - - - - - - - - - - - # stock symbol lookup: http://finance.yahoo.com/l # e.g. aapl ko ibm msft rhat sunw my $stocksymbol = "rhat"; my $startdate = "4-15-2002"; # since it's for historical date, my $enddate = "6-30-2003"; # latest data may not be available my $interval = "d"; # d: daily, w: weekly, m: monthly my $agent = "Mozilla/4.0"; # your id sent to Yahoo Web server, enter something my $q = quotes::get($stocksymbol, $startdate, $enddate, $interval, $agent); my ($ma, $diff) = (20, 1); # lags for MA & differencing open OUT, ">$stocksymbol.html"; print OUT chart::html($stocksymbol, $q, $ma, $diff); # expecting headers: Date,Open,High,Low,Close,Volume close OUT; print "done: $stocksymbol.html generated.\n"; {package quotes; use LWP::UserAgent; sub get { my ($symbol, $startdate, $enddate, $agent) = @_; print "fetching data...\n"; my $dat = _fetch($symbol, $startdate, $enddate, $agent); # csv file, 1st row = header my @q = split /\n/, $dat; my @header = split /,/, shift @q; my %quotes = map { $_ => [] } @header; for my $q (@q) { my @val = split ',', $q; unshift @{$quotes{$header[$_]}}, $val[$_] for 0..$#val; # unshift instead of push if data listed latest 1st & oldest last } open OUT, ">$symbol.csv"; print OUT $dat; close OUT; print "data written to $symbol.csv.\n"; return \%quotes; } sub _fetch { my ($symbol, $startdate, $enddate, $interval, $agent) = @_; my $url = "http://chart.yahoo.com/table.csv?"; my $freq = "g=$interval"; # d: daily, w: weekly, m: monthly my $stock = "s=$symbol"; my @start = split '-', $startdate; my @end = split '-', $enddate; $startdate = "a=" . ($start[0]-1) . "&b=$start[1]&c=$start[2]"; $enddate = "d=" . ($end[0]-1) . "&e=$end[1]&f=$end[2]"; $url .= "$startdate&$enddate&$stock&y=0&$freq&ignore=.csv"; my $ua = new LWP::UserAgent(agent=>$agent); my $request = new HTTP::Request('GET',$url); my $response = $ua->request($request); if ($response->is_success) { return $response->content; } else { warn "Cannot fetch $url (status ", $response->code, " ", $response->message, ")\n"; return 0; } } } {package chart; use GD::Graph::lines; # my @headers = qw/ Date Open High Low Close Volume /; hardcoded in _tbl() # $q->{Close} assumed exists in plotlog() & plotdiff() sub html { my ($stock, $q, $ma, $diff) = @_; print "generating html...\n"; my $str = ""; $str .= "$stock
\n"; $str .= "

\n"; $str .= "

\n"; $str .= _tbl($stock, $q); $str .= "
\n"; return $str; } sub plotlog { my ($stock, $q, $diff) = @_; my $img = $stock . "log.jpg"; print "generating $img...\n"; my ($s, $lines) = ([],[]); my $y_format = sub { sprintf " \$%.2f", exp $_[0] }; $s = ts::logs($q->{Close}); $lines->[0] = { name => 'Log of Closing Price', color => 'marine', data => $s }; $lines->[1] = { name => "MA($diff) (Moving Avg)", color => 'cyan', data => ts::ma($lines->[0]->{data}, $diff) }; plotlines($img, $stock, $q->{Date}, $lines, $y_format); return $img; } sub plotdiff { my ($stock, $q, $lag, $diff) = @_; my $img = $stock . "diff.jpg"; print "generating $img...\n"; my ($s, $lines) = ([],[]); my $y_format = sub { sprintf " %.2f", $_[0] }; $s = ts::logs($q->{Close}); $lines->[0] = { name => "Diff($diff)", color => 'marine', data => ts::diff($s, $diff) }; $lines->[1] = { name => "MA($lag) (Moving Avg)", color => 'cyan', data => ts::ma($lines->[0]->{data}, $lag) }; $s = ts::stdev($lines->[0]->{data}, $lag); $s = ts::nstdev_ma($s, $lines->[1]->{data}, 2); $lines->[2] = { name => 'MA + 2 Std Dev', color => 'lred', data => $s->[0] }; $lines->[3] = { name => 'MA - 2 Std Dev', color => 'lred', data => $s->[1] }; plotlines($img, $stock, $q->{Date}, $lines, $y_format); return $img; } sub plotlines { my ($file, $stock, $x, $lines, $y_format) = @_; my @legend; my ($data, $colors) = ([], []); $data->[0] = $x; # x-axis labels for (0..$#{$lines}) { $data->[(1+$_)] = $lines->[$_]->{data}; $colors->[$_] = $lines->[$_]->{color}; $legend[$_] = $lines->[$_]->{name}; } my $graph = GD::Graph::lines->new(740,420); $graph->set (dclrs => $colors) or die $graph->error; $graph->set_legend(@legend) or die $graph->error; $graph->set (legend_placement => 'BC') or die $graph->error; $graph->set(y_number_format => $y_format) if $y_format; $graph->set ( title => "stock: $stock", boxclr => 'black', bgclr => 'dgray', axislabelclr => 'white', legendclr => 'white', textclr => 'white', r_margin => 20, tick_length => -4, y_long_ticks => 1, axis_space => 10, x_labels_vertical => 1, x_label_skip => int(0.2*scalar(@{$data->[0]})) ) or die $graph->error; my $gd = $graph->plot($data) or die $graph->error; open (IMG, ">$file") or die $!; binmode IMG; print IMG $gd->jpeg(90); return 1; } sub _tbl { my ($stock, $q) = @_; my $str = ""; my @headers = qw/ Date Open High Low Close Volume /; my $tr_start = "\n"; $str .= "\n"; $str .= $tr_start . "\n"; $str .= $tr_start; $str .= "\n" for 0..$#headers; $str .= "\n"; for my $i (reverse 0..$#{$q->{Date}}) { $str .= $tr_start; $str .= "\n" for 0..$#headers; $str .= "\n"; } $str .= "
"; $str .= "Stock: $stock
" . $headers[$_] . "
" . $q->{$headers[$_]}->[$i] . "
\n"; return $str; } } {package ts; sub logs { my $s = shift; return [ map {log} @{$s}[0..$#{$s}] ]; } sub diff { my ($series, $lag) = @_; my @diff = map {undef} 1..$lag; push @diff, $series->[$_] - $series->[$_-$lag] for ( $lag..$#{$series} ); return \@diff; } sub ma { my ($series, $lag) = @_; my @ma = map {undef} 1..$lag; for(@{$series}){unless($_){push @ma,undef}else{last}} my $sum = 0; for my $i ($#ma..$#{$series}) { $sum += $series->[$i-$_] for (0..($lag-1)); push @ma, $sum/($lag); $sum = 0; } return \@ma; } sub stdev { my ($series, $lag) = @_; my @stdev = map {undef} 1..$lag; for(@{$series}){unless($_){push @stdev,undef}else{last}} my ($sum, $sum2) = (0, 0); for my $i ($#stdev..$#{$series}) { for (0..($lag-1)) { $sum2 += ($series->[$i-$_])**2; $sum += $series->[$i-$_] ; } push @stdev, ($sum2/$lag - ($sum/$lag)**2)**0.5; ($sum, $sum2) = (0, 0); } return \@stdev; } sub nstdev_ma{ my ($sd, $ma, $n) = @_; my $ans=[[],[]]; for (0..$#{$sd}) { my $yn = defined $sd->[$_] && defined $ma->[$_]; $ans->[0][$_] = $yn ? $ma->[$_] + $n*($sd->[$_]) : undef; $ans->[1][$_] = $yn ? $ma->[$_] - $n*($sd->[$_]) : undef; } return $ans; } }