2回目になりますが、またrvestで過去のレース結果を落としてみたいと思います。過去の記事を見てないという人は先にそちらをご覧になられることをお勧めします。
今回データを取り直そうと思ったのは、競馬の分析をした際により多くの項目を説明変数に加えて、分析をしたいと思ったからです。なので、今回は前回のRスクリプトに追記を行う形でプログラムを作成しました。新たに追加したデータ項目は以下の14個です。
- 芝かダートか
- 右回りか左回りか
- レースコンディション（良や稍重など）
- 天候
- 馬の毛色（栗毛、鹿毛など）
- 馬主
- 生産者
- 産地
- 生年月日
- 父馬
- 母馬
- そのレースまでの獲得賞金（2003年から入手可能）
- ジョッキーの体重
- ジョッキーの体重の増減
実はまだデータ収集は終わっていなくて、Rのプログラムがずっと実行中になっています（3日くらい回しています）。しかし、プログラム自体はきっちり回っているのでスクリプトの紹介をしていこうと思います。もしかしたら追記で結果を書くかもしれません。
スクリプトの中身
まずはパッケージの呼び出しです。
# rvestによる競馬データのwebスクレイピング
#install.packages("rvest")
#if (!require("pacman")) install.packages("pacman")
#install.packages("beepr")
#install.packages("RSQLite")
pacman::p_load(qdapRegex)
library(rvest)
library(stringr)
library(dplyr)
library(beepr)
library(RSQLite)かなりwarnningが出るのでそれを禁止し、SQLiteに接続しています
# warnning禁止
options(warn=-1)
# SQLiteへの接続
con = dbConnect(SQLite(), "horse_data.db", synchronous="off")1994年からしかオッズが取れないので、1994年から直近までのデータを取得します。yahoo競馬では月ごとにレースがまとめられているので、それを変数として使用しながらデータをとっていきます。基本的には、該当年、該当月のレース結果一覧へアクセスし、そのページ上の各日の個々の競馬場ごとのタイムテーブルへのリンクを取得します。個々の競馬場でレースはだいたい12ほどあるので、そのリンクを取得し、各レースのレース結果ページにアクセスします。そして、レース結果を取得していきます。まず、各日の個々の競馬場ごとのタイムテーブルへのリンクの取得方法です。
for(year in 1994:2019){
start.time <- Sys.time() # 計算時間を図る
# yahoo競馬のレース結果一覧ページの取得
for (k in 1:12){ # kは月を表す
tryCatch(
{
keiba.yahoo <- read_html(str_c("https://keiba.yahoo.co.jp/schedule/list/", year,"/?month=",k)) # 該当年、該当月のレース結果一覧にアクセス
Sys.sleep(2)
race_lists <- keiba.yahoo %>%
html_nodes("a") %>%
html_attr("href") # 全urlを取得
# 競馬場ごとの各日のレースリストを取得
race_lists <- race_lists[str_detect(race_lists, pattern="race/list/\\d+/")==1] # 「result」が含まれるurlを抽出
}
, error = function(e){signal <- 1}
)ここでは、取得したリンクのurlにresultという文字が含まれているものだけを抽出しています。要はそれが各競馬場のレーステーブルへのリンクとなります。ここからは取得した競馬場のレーステーブルのリンクを用いて、そのページにアクセスし、全12レースそれぞれのレース結果が掲載されているページのリンクを取得していきます。
for (j in 1:length(race_lists)){ # jは当該年月にあったレーステーブルへのリンクを表す
tryCatch(
{
race_list <- read_html(str_c("https://keiba.yahoo.co.jp",race_lists[j]))
race_url <- race_list %>% html_nodes("a") %>% html_attr("href") # 全urlを取得
# レース結果のurlを取得
race_url <- race_url[str_detect(race_url, pattern="result")==1] # 「result」が含まれるurlを抽出
}
, error = function(e){signal <- 1}
)各レース結果へのリンクが取得できたので、ここからはいよいよレース結果の取得とその整形パートに入ります。かなり長ったらしく複雑なコードになってしまいました。レース結果は以下のようなテーブル属性に格納されているので、まずそれを単純に引っ張ってきます。
for (i in 1:length(race_url)){ # iは当該年月当該競馬場で開催されたレースを表す
print(str_c("現在、", year, "年", k, "月",j, "グループ、", i,"番目のレースの保存中です"))
tryCatch(
{
race1 <- read_html(str_c("https://keiba.yahoo.co.jp",race_url[i])) # レース結果のurlを取得
signal <- 0
Sys.sleep(2)
}
, error = function(e){signal <- 1}
)
# レースが中止orこれまでの過程でエラーでなければ処理を実行
if (identical(race1 %>%
html_nodes(xpath = "//div[@class = 'resultAtt mgnBL fntSS']") %>%
html_text(),character(0)) == TRUE && signal == 0){
# レース結果をスクレイピング
race_result <- race1 %>% html_nodes(xpath = "//table[@id = 'raceScore']") %>%
html_table()
race_result <- do.call("data.frame",race_result) # リストをデータフレームに変更
colnames(race_result) <- c("order","frame_number","horse_number","horse_name/age","time/margin","passing_rank/last_3F","jockey/weight","popularity/odds","trainer") # 列名変更tableをただ取得しただけでは以下のように、一つのセルに複数の情報が入っていたりと分析には使えないデータとなっています。なので、これを成型する必要が出てきます。
# 通過順位と上り3Fのタイム
race_result <- dplyr::mutate(race_result,passing_rank=as.character(str_extract_all(race_result$`passing_rank/last_3F`,"(\\d{2}-\\d{2}-\\d{2}-\\d{2})|(\\d{2}-\\d{2}-\\d{2})|(\\d{2}-\\d{2})")))
race_result <- dplyr::mutate(race_result,last_3F=as.character(str_extract_all(race_result$`passing_rank/last_3F`,"\\d{2}\\.\\d")))
race_result <- race_result[-6]
# タイムと着差
race_result <- dplyr::mutate(race_result,time=as.character(str_extract_all(race_result$`time/margin`,"\\d\\.\\d{2}\\.\\d|\\d{2}\\.\\d")))
race_result <- dplyr::mutate(race_result,margin=as.character(str_extract_all(race_result$`time/margin`,"./.馬身|.馬身|.[:space:]./.馬身|[ア-ン-]+")))
race_result$margin[race_result$order==1] <- "トップ"
race_result$margin[race_result$margin=="character(0)"] <- "大差"
race_result$margin[race_result$order==0] <- NA
race_result <- race_result[-5]
# 馬名、馬齢、馬体重
race_result <- dplyr::mutate(race_result,horse_name=as.character(str_extract_all(race_result$`horse_name/age`,"[ァ-ヴー・]+")))
race_result <- dplyr::mutate(race_result,horse_age=as.character(str_extract_all(race_result$`horse_name/age`,"牡\\d+|牝\\d+|せん\\d+")))
race_result$horse_sex <- str_extract(race_result$horse_age, pattern = "牡|牝|せん")
race_result$horse_age <- str_extract(race_result$horse_age, pattern = "\\d")
race_result <- dplyr::mutate(race_result,horse_weight=as.character(str_extract_all(race_result$`horse_name/age`,"\\d{3}")))
race_result <- dplyr::mutate(race_result,horse_weight_change=as.character(str_extract_all(race_result$`horse_name/age`,"\\([\\+|\\-]\\d+\\)|\\([\\d+]\\)")))
race_result$horse_weight_change <- sapply(rm_round(race_result$horse_weight_change, extract=TRUE), paste, collapse="")
race_result <- dplyr::mutate(race_result,brinker=as.character(str_extract_all(race_result$`horse_name/age`,"B")))
race_result$brinker[race_result$brinker!="B"] <- "N"
race_result <- race_result[-4]
# ジョッキー
race_result <- dplyr::mutate(race_result,jockey=as.character(str_extract_all(race_result$`jockey/weight`,"[ぁ-ん一-龠]+\\s[ぁ-ん一-龠]+|[:upper:].[ァ-ヶー]+")))
race_result <- dplyr::mutate(race_result,jockey_weight=as.character(str_extract_all(race_result$`jockey/weight`,"\\d{2}")))
race_result$jockey_weight_change <- 0
race_result$jockey_weight_change[str_detect(race_result$`jockey/weight`,"☆")==1] <- 1
race_result$jockey_weight_change[str_detect(race_result$`jockey/weight`,"△")==1] <- 2
race_result$jockey_weight_change[str_detect(race_result$`jockey/weight`,"△")==1] <- 3
race_result <- race_result[-4]
# オッズと人気
race_result <- dplyr::mutate(race_result,odds=as.character(str_extract_all(race_result$`popularity/odds`,"\\(.+\\)")))
race_result <- dplyr::mutate(race_result,popularity=as.character(str_extract_all(race_result$`popularity/odds`,"\\d+[^(\\d+.\\d)]")))
race_result$odds <- sapply(rm_round(race_result$odds, extract=TRUE), paste, collapse="")
race_result <- race_result[-4]次に、今取得したtable以外の情報も取り込むことにします。具体的には、レース名や天候、馬場状態、日付、競馬場などです。これらの情報はレース結果ページの上部に掲載されています。
# レース情報
race_date <- race1 %>% html_nodes(xpath = "//div[@id = 'raceTitName']/p[@id = 'raceTitDay']") %>%
html_text()
race_name <- race1 %>% html_nodes(xpath = "//div[@id = 'raceTitName']/h1[@class = 'fntB']") %>%
html_text()
race_distance <- race1 %>% html_nodes(xpath = "//p[@id = 'raceTitMeta']") %>%
html_text()
race_result <- dplyr::mutate(race_result,race_date=as.character(str_extract_all(race_date,"\\d+年\\d+月\\d+日")))
race_result$race_date <- str_replace_all(race_result$race_date,"年","/")
race_result$race_date <- str_replace_all(race_result$race_date,"月","/")
race_result$race_date <- as.Date(race_result$race_date)
race_course <- as.character(str_extract_all(race_date,pattern = "札幌|函館|福島|新潟|東京|中山|中京|京都|阪神|小倉"))
race_result$race_course <- race_course
race_result <- dplyr::mutate(race_result,race_name=as.character(str_replace_all(race_name,"\\s","")))
race_result <- dplyr::mutate(race_result,race_distance=as.character(str_extract_all(race_distance,"\\d+m")))
race_type=as.character(str_extract_all(race_distance,pattern = "芝|ダート"))
race_result$type <- race_type
race_turn <- as.character(str_extract_all(race_distance,pattern = "右|左"))
race_result$race_turn <- race_turn
if(length(race1 %>% html_nodes(xpath = "//img[@class = 'spBg ryou']")) == 1){
race_result$race_condition <- "良"
} else if (length(race1 %>%
html_nodes(xpath = "//img[@class = 'spBg yayaomo']")) == 1){
race_result$race_condition <- "稍重"
} else if (length(race1 %>%
html_nodes(xpath = "//img[@class = 'spBg omo']")) == 1){
race_result$race_condition <- "重"
} else if (length(race1 %>%
html_nodes(xpath = "//img[@class = 'spBg furyou']")) == 1){
race_result$race_condition <- "不良"
} else race_result$race_condition <- "NA"
if (length(race1 %>% html_nodes(xpath = "//img[@class = 'spBg hare']")) == 1){
race_result$race_weather <- "晴れ"
} else if (length(race1 %>% html_nodes(xpath = "//img[@class = 'spBg ame']")) == 1){
race_result$race_weather <- "曇り"
} else if (length(race1 %>% html_nodes(xpath = "//img[@class = 'spBg kumori']")) == 1){
race_result$race_weather <- "雨"
} else race_result$race_weather <- "その他"次は各馬の情報です。 実はさきほど取得したtableの馬名はリンクになっており、そのリンクをたどると各馬の情報が取得できます（毛色や生年月日など）。
horse_url <- race1 %>% html_nodes("a") %>% html_attr("href")
horse_url <- horse_url[str_detect(horse_url, pattern="directory/horse")==1] # 馬情報のリンクだけ抽出する
for (l in 1:length(horse_url)){
tryCatch(
{
horse1 <- read_html(str_c("https://keiba.yahoo.co.jp",horse_url[l]))
Sys.sleep(0.5)
horse_name <- horse1 %>% html_nodes(xpath = "//div[@id = 'dirTitName']/h1[@class = 'fntB']") %>%
html_text()
horse <- horse1 %>% html_nodes(xpath = "//div[@id = 'dirTitName']/ul") %>%
html_text()
race_result$colour[race_result$horse_name==horse_name] <- as.character(str_extract_all(horse,"毛色：.+"))
race_result$owner[race_result$horse_name==horse_name] <- as.character(str_extract_all(horse,"馬主：.+"))
race_result$farm[race_result$horse_name==horse_name] <- as.character(str_extract_all(horse,"生産者：.+"))
race_result$locality[race_result$horse_name==horse_name] <- as.character(str_extract_all(horse,"産地：.+"))
race_result$horse_birthday[race_result$horse_name==horse_name] <- as.character(str_extract_all(horse,"\\d+年\\d+月\\d+日"))
race_result$father[race_result$horse_name==horse_name] <- horse1 %>% html_nodes(xpath = "//td[@class = 'bloodM'][@rowspan = '4']") %>% html_text()
race_result$mother[race_result$horse_name==horse_name] <- horse1 %>% html_nodes(xpath = "//td[@class = 'bloodF'][@rowspan = '4']") %>% html_text()
}
, error = function(e){
race_result$colour[race_result$horse_name==horse_name] <- NA
race_result$owner[race_result$horse_name==horse_name] <- NA
race_result$farm[race_result$horse_name==horse_name] <- NA
race_result$locality[race_result$horse_name==horse_name] <- NA
race_result$horse_birthday[race_result$horse_name==horse_name] <- NA
race_result$father[race_result$horse_name==horse_name] <- NA
race_result$mother[race_result$horse_name==horse_name] <- NA
}
)
}
race_result$colour <- str_replace_all(race_result$colour,"毛色：","")
race_result$owner <- str_replace_all(race_result$owner,"馬主：","")
race_result$farm <- str_replace_all(race_result$farm,"生産者：","")
race_result$locality <- str_replace_all(race_result$locality,"産地：","")
#race_result$horse_birthday <- str_replace_all(race_result$horse_birthday,"年","/")
#race_result$horse_birthday <- str_replace_all(race_result$horse_birthday,"月","/")
#race_result$horse_birthday <- as.Date(race_result$horse_birthday)
race_result <- dplyr::arrange(race_result,horse_number) # 馬番順に並べる次にそのレースまでに獲得した賞金額を落としに行きます。これはレース結果のページの出馬表と書かれたリンクをたどるとアクセスできます。ここに賞金があるのでそれを取得します。
yosou_url <- race1 %>% html_nodes("a") %>% html_attr("href")
yosou_url <- yosou_url[str_detect(yosou_url, pattern="denma")==1]
if (length(yosou_url)==1){
yosou1 <- read_html(str_c("https://keiba.yahoo.co.jp",yosou_url))
Sys.sleep(2)
yosou <- yosou1 %>% html_nodes(xpath = "//td[@class = 'txC']") %>% as.character()
prize <- yosou[grepl("万",yosou)==TRUE] %>% str_extract_all("\\d+万")
prize <- t(do.call("data.frame",prize)) %>% as.character()
race_result$prize <- prize
race_result$prize <- str_replace_all(race_result$prize,"万","") %>% as.numeric()
} else race_result$prize <- NA取得した各レース結果を格納するdatasetというデータフレームを作成し、データを格納していきます。1年ごとにそれをSQLite へ保存していきます。
## ファイル貯めるのかく
if (k == 1 && i == 1 && j == 1){
dataset <- race_result
} else {
dataset <- rbind(dataset,race_result)
} # if文2の終わり
}else
{
print("保存できませんでした")
}# if文1の終わり
} # iループの終わり
} # jループ終わり
} # kループの終わり
beep(3)
write.csv(dataset,"race_result2.csv", row.names = FALSE)
if (year == 1994){
dbWriteTable(con, "race_result", dataset)
} else {
dbWriteTable(con, "temp", dataset)
dbSendQuery(con, "INSERT INTO race_result select * from temp")
dbSendQuery(con, "DROP TABLE temp")
} # ifの終わり
} # yearループの終わり
end.time <- Sys.time()
print(str_c("処理時間は",end.time-start.time,"です。"))
beep(5)
options(warn = 1)
dbDisconnect(con)以上です。取れたデータは以下のようになりました。
## order frame_number horse_number trainer passing_rank last_3F time
## 1 10 1 1 田中 剛 09-09 39.0 1.14.3
## 2 16 1 2 天間 昭一 11-11 40.3 1.15.7
## 3 15 2 3 田中 清隆 14-14 39.4 1.15.1
## 4 9 2 4 中舘 英二 08-08 39.1 1.14.3
## 5 12 3 5 根本 康広 11-11 39.0 1.14.4
## 6 4 3 6 杉浦 宏昭 04-04 38.4 1.13.2
## margin horse_name horse_age horse_sex horse_weight
## 1 アタマ サトノジョニー 3 牡 512
## 2 3 1/2馬身 ツギノイッテ 3 牡 464
## 3 3馬身 ギュウホ 3 牡 444
## 4 2 1/2馬身 セイウンメラビリア 3 牝 466
## 5 クビ サバイバルトリック 3 牝 450
## 6 アタマ ステイホット 3 牝 474
## horse_weight_change brinker jockey jockey_weight
## 1 +30 N 松岡 正海 56
## 2 +8 N 西田 雄一郎 56
## 3 +8 N 杉原 誠人 56
## 4 +10 N 村田 一誠 54
## 5 -2 N 野中 悠太郎 51
## 6 -2 N 大野 拓弥 54
## jockey_weight_change odds popularity race_date race_course
## 1 0 40.3 9 2019-01-05 中山
## 2 0 340.9 16 2019-01-05 中山
## 3 0 283.1 14 2019-01-05 中山
## 4 0 299.7 15 2019-01-05 中山
## 5 0 26.7 8 2019-01-05 中山
## 6 0 2.4 1 2019-01-05 中山
## race_name race_distance type race_turn race_condition
## 1 サラ系3歳未勝利 1200m ダート 右 良
## 2 サラ系3歳未勝利 1200m ダート 右 良
## 3 サラ系3歳未勝利 1200m ダート 右 良
## 4 サラ系3歳未勝利 1200m ダート 右 良
## 5 サラ系3歳未勝利 1200m ダート 右 良
## 6 サラ系3歳未勝利 1200m ダート 右 良
## race_weather colour owner farm
## 1 晴れ 栗毛 株式会社 サトミホースカンパニー 千代田牧場
## 2 晴れ 黒鹿毛 西村 新一郎 織笠 時男
## 3 晴れ 鹿毛 有限会社 ミルファーム 神垣 道弘
## 4 晴れ 青鹿毛 西山 茂行 石郷岡 雅樹
## 5 晴れ 黒鹿毛 福田 光博 原田牧場
## 6 晴れ 栗毛 小林 善一 社台ファーム
## locality horse_birthday father mother
## 1 新ひだか町 2016年1月29日 オルフェーヴル スパークルジュエル
## 2 青森県 2016年4月17日 スクワートルスクワート エプソムアイリス
## 3 新ひだか町 2016年4月19日 ジャングルポケット デライトシーン
## 4 新冠町 2016年4月21日 キンシャサノキセキ ドリームシップ
## 5 日高町 2016年4月30日 リーチザクラウン フリーダムガール
## 6 千歳市 2016年3月13日 キャプテントゥーレ ステイアライヴ
## prize
## 1 0
## 2 0
## 3 0
## 4 0
## 5 180
## 6 455