### S3 class 'gogame' is defined ###
#' Go game object
#' @description \code{gogame} class object capusulizes a go game record.
#' It stores player names, game plays, outcomes and other information such
#' as location and date.
#' The object supports various methods for creating board images and
#' kifu documents.
#' @param properties a list of game properties
#' @param gametree a list
#' @return \code{gogame} object
#' @export
#' @seealso \code{\link{read_sgf}}, \code{\link{parse_sgf}},
#' \code{\link{plotat}}, \code{\link{stateat}}, \code{\link{kifu}}, \code{\link{kifuplot}}
#' @details This is a constructor of \code{gogame} class object.
#' It is mainly designed to be called from \code{\link{parse_sgf}} function,
#' which interprets text of sgf format and creates the corresponding
#' \code{gogame} object.
#'
#' The object can produce two kinds of game images.
#' The first is a board snapshot at an arbitrary timing.
#' \code{\link{stateat}} is for computing the board configuration and
#' \code{\link{plotat}} for drawing the board image.
#' The second is the kifu document that summarize a range of
#' moves in a page.
#' \code{\link{kifu}} computes the contant of a kifu document and
#' \code{\link{kifuplot}} draws the document image.
#'
#' The constructor takes two mandatory arguments: \code{properties} and \code{gametree}.
#' \code{properties} is a named list of game meta information.
#' Currently, following names are recognized (variable type in parentheses).
#' One may provide additional information so long as it does not contradict
#' names of other information. Check \code{str(mimiaka)} to see a list of
#' variable names already in use.
#' \describe{
#' \item{\code{boardsize}}{board size (\code{integer}}
#' \item{\code{whitename}, \code{whiterank}, \code{blackname}, \code{blackrank}}{player
#' names and ranks (\code{character})}
#' \item{\code{komi}}{Komi (\code{numeric})}
#' \item{\code{handicap}}{number of handicap stones (\code{integer})}
#' \item{\code{result}}{game outcome (\code{character})}
#' \item{\code{date}, \code{place}}{game date and location (\code{character})}
#' \item{\code{event}, \code{round}}{competition or event name and round (\code{character})}
#' \item{\code{rule}}{rule (\code{character})}
#' }
#'
#' \code{gametree} stores game plays, setups, comments, and territory counts.
#' To accomodate the cases of games with branches, the object employs a tree
#' data structure.
#' \code{gametree} should contain potentially four data sets.
#' Parentheses list the variable names to be contained.
#' \describe{
#' \item{\code{transition}}{Transition of board configuration.
#' a positive value means a stone is added, negative means removed.
#' Absolute values of value indicate the stone color (1: black, 2: white)
#' (\code{x}, \code{y}, \code{value}, \code{move}, \code{nodeid})}
#' \item{\code{move}}{Moves and setups. \code{ismove} indicates whether it is a
#' move or setup (\code{x}, \code{y}, \code{color}, \code{ismove}, \code{move}, \code{nodeid})}
#' \item{\code{point}}{Territories.
#' (\code{x}, \code{y}, \code{color}, \code{move}, \code{nodeid})}
#' \item{\code{comment}}{Comments made during the game.
#' (\code{comment}, \code{move}, \code{nodeid})}
#' }
#' \code{nodeid} variable in each data indicates the tree node to which the row belongs to.
#'
#' \code{gametree} also include three variables that describe tree structure.
#' \describe{
#' \item{\code{parent}}{integer vector that points parent of each node. The first node is always
#' assumed to be the root node and its parent is zero}
#' \item{\code{children}}{list of integer vector that points children of each node}
#' \item{\code{leaf}}{integer vector of leaf nodes (i.e. no children)}
#' }
#' For example, when there is only one node, \code{nodeid} variable of all data should be 1,
#' and \code{parent} is 0 (there is only the root node), \code{children} has unique entry
#' and it is integer vector of length zero, and \code{leaf} is 1.
#' When some of the three components are missing, then the function tries the best to
#' recover from the supplied information
#'
#' When \code{transition} is missing, then the function tries to compute it using
#' \code{move} and tree structure information.
#'
gogame <- function(properties, gametree)
{
## input validity check
if (!is.list(properties)) stop("properties must be a list")
if (!is.list(gametree)) stop("gametree must be a list")
## clean properties
### impute missing properties with NA
prop_names <- c("whitename", "whiterank", "blackname", "blackrank",
"boardsize", "komi", "handicap", "date", "event", "round",
"result", "rule", "place") %>%
setdiff(names(properties))
properties[prop_names] <- NA_character_
### clean boardsize
properties$boardsize <- guess_boardsize(properties$boardsize, 0L)
### clean komi
# if not specified, assume komi is zero
if (is.na(properties$komi)) {
properties$komi <- 0L
} else if (is.character(properties$komi)) {
# if there komi is interpretable as numeric, then convert to numeric
if (grepl("^[[:space:]]*[\\-\\.0-9]+[[:space:]]*$", properties$komi))
properties$komi <- as.numeric(properties$komi)
}
### clean handicap
# Decided NOT to
# - check if the handicap is consistent with the number of setup moves
# - guess and fill the handicap propperty based on the number of setup moves
if (is.na(properties$handicap)) {
properties$handicap <- 0L
} else if (!is.na(properties$handicap)) {
# convert to integer
properties$handicap <- grep("[0-9]+", properties$handicap, value = TRUE) %>%
as.integer()
}
## impute tree structure (parent, children, leaf), if any is missing
### In principle, one should supply
### wither all components or none of them
### If none of them is supplied, assumes there is only one node, which is 1
### If partial information is supplied, then the following function
### tries to impute the missing components
gametree[c("parent", "children", "leaf")] <- do.call(
fill_tree_structure, gametree[c("parent", "children", "leaf")])
### check consistency of tree structure
check <- do.call(
check_tree_structure, gametree[c("parent", "children", "leaf")])
if (!check) stop("invalid tree strucure")
## check game tree
### gametree includes the following data.frames:
### transition: x, y, value, move, nodeid
### move : x, y, color, ismove, move, nodeid
### point : x, y, color, move, nodeid
### comment : comment, move, nodeid
### and following tree structure information:
### parent : integer vector
### children: list of integer vector
### leaf : integer vector
###
### If transiion is missing, then we need to make one using the move
if (!("transition" %in% names(gametree)) && !("move" %in% names(gametree)))
stop("transition or move must be supplied in game tree")
### if transition is missing and move exists, then
### compute the transition using move children (children may possibly be NULL)
if (!("transition" %in% names(gametree)) && ("move" %in% names(gametree)))
gametree$transition <- get_transition_wrapper(
gametree$move, gametree$children)
### valiable name check
if (is.null(gametree$transition)) stop("game transition is missing")
varnames <- c("x", "y", "value", "move", "nodeid")
check <- varnames %in% names(gametree$transition)
if (any(!check))
stop("transition data must contain ", paste0(varnames, collapse = ", "))
### if point or comment is missing, then impute empty data.frame
### otherwise check variable names
if (is.null(gametree$point)) {
gametree$point <- data.frame(
color = integer(0), x = integer(0), y = integer(0),
move = integer(0), nodeid = integer(0))
} else {
varnames <- c("x", "y", "color", "move", "nodeid")
check <- varnames %in% names(gametree$point)
if (any(!check))
stop("point data must contain ", paste0(varnames, collapse = ", "))
}
if (is.null(gametree$comment)) {
gametree$comment <- data.frame(
comment = character(0), move = integer(0), nodeid = integer(0),
stringsAsFactors = FALSE)
} else {
varnames <- c("comment", "move", "nodeid")
check <- varnames %in% names(gametree$comment)
if (any(!check))
stop("comment data must contain ", paste0(varnames, collapse = ", "))
}
### remove points with out-of-bounds coordinates
### do not do the same for transition or move since OB represents pass
gametree$point <- dplyr::filter_(gametree$point,
~x >= 1L, ~x <= properties$boardsize,
~y >= 1L, ~y <= properties$boardsize)
## compile output
### we don't need 'move' in the game tree any longer
gametree <- gametree[names(gametree) != "move"]
out <- structure(
.Data = c(properties, list(gametree = gametree)), class = "gogame")
out <- set_gamepath(out, 1L)
## store the move count of main branch (branch = 1)
out$mainpathmoves <- max(c(0L, out$transition$move))
return(out)
}
#' @export
print.gogame <- function(x, ...)
{
cat("* Go game *\n\n")
cat(" White : ")
if (!is.na(x$whitename)) cat(x$whitename)
if (!is.na(x$whiterank)) cat(sprintf(" (%s)", as.character(x$whiterank)))
cat("\n")
cat(" Black : ")
if (!is.na(x$blackname)) cat(x$blackname)
if (!is.na(x$blackrank)) cat(sprintf(" (%s)", as.character(x$blackrank)))
cat("\n")
cat(" Result: ")
if (!is.na(x$result)) {
cat(x$result)
} else {
cat("Unknown")
}
if (is.integer(x$mainpathmoves))
cat(sprintf(" (%d moves)", x$mainpathmoves))
cat("\n")
cat("\n")
cat(sprintf(" %-12s: %s\n", "komi", as.character(x$komi), "\n"))
if (!is.na(x$handicap))
cat(sprintf(" %-12s: %s\n", "handicap", as.character(x$handicap), "\n"))
cat(sprintf(" %-12s: %s\n", "board size", as.character(x$boardsize), "\n"))
if (!is.na(x$rule))
cat(sprintf(" %-12s: %s\n", "rule", as.character(x$rule), "\n"))
if (!is.na(x$date))
cat(sprintf(" %-12s: %s\n", "date", as.character(x$date), "\n"))
if (!is.na(x$place))
cat(sprintf(" %-12s: %s\n", "place", as.character(x$place), "\n"))
if (!is.na(x$event))
cat(sprintf(" %-12s: %s\n", "event", as.character(x$event), "\n"))
if (!is.na(x$round))
cat(sprintf(" %-12s: %s\n", "round", as.character(x$round), "\n"))
if (length(x$gametree$leaf) > 1L) {
cat(sprintf(
"\n* currently at path %d / %d (%d moves)\n",
x$pathid, length(x$gametree$leaf), max(c(0L, x$transition$move))))
}
}
#' @export
as.list.gogame <- function(x, ...)
{
return(x[])
}
#' Check if the object is gogame class
#' @param x R object
#' @return logical
#' @export
is.gogame <- function(x)
{
return(inherits(x, "gogame"))
}
### following functions are not registered as generic method for the class,
### but assumes the arguments are the gogame class object
#' Go board status at a move number
#' @description Computes the board state at a certain move number for a game.
#' @param x \code{gogame} object
#' @param at integer of the move number
#' @return \code{stateat} returns a \code{\link{gostate}} object
#' @export
#' @examples
#' stateat(saikoyo, 116)
stateat <- function(x, at)
{
if (!(is.gogame(x))) stop("object is not a gogame")
boardsize <- x$boardsize
# the following data frame represent the board state in
# dense matrix format
board <- x$transition %>%
dplyr::filter_(~move <= at, ~x >= 1L, ~y >= 1L,
~x <= boardsize, ~y <= boardsize) %>%
dplyr::group_by_(~x, ~y) %>%
dplyr::summarize_(value = ~sum(value)) %>%
dplyr::filter_(~value > 0L) %>%
dplyr::rename_(color = ~value) %>%
dplyr::ungroup()
# compute the number of prisoners
capt <- x$transition %>%
dplyr::filter_(~move <= at, ~value < 0L) %>%
dplyr::group_by_(~value) %>%
dplyr::summarize_(captured = ~length(move))
b_captured <- 0L
flg <- (capt$value == -BLACK)
if (any(flg)) b_captured <- capt$captured[flg]
w_captured <- 0L
flg <- capt[["value"]] == -WHITE
if (any(flg)) w_captured <- capt$captured[flg]
# find the last move
dat <- x$transition %>%
dplyr::filter_(~move <= at, ~move >= 1L, ~value > 0L) %>%
dplyr::arrange_(~move) %>% utils::tail(1)
if (nrow(dat) == 1L) {
lastmove <- c(dat$x, dat$y, dat$value)
} else {
lastmove <- NULL
}
# find the territories and comment,
## we look for the same move number as the last move above,
## except for the case with at is 0,
## where find the comment and point with move = 0
if (at == 0L) {
tgt_move <- 0L
} else {
tgt_move <- dat$move
}
points <- dplyr::filter_(x$point, ~move == tgt_move)
comment <- x$comment$comment[x$comment$move == tgt_move]
out <- gostate(board, boardsize = x$boardsize, movenumber = tgt_move,
b_captured = b_captured, w_captured = w_captured,
lastmove = lastmove, points = points, comment = comment)
return(out)
}
#' @param ... arguments passed to \code{\link{plot.gostate}}
#' @return \code{plotat} returns a \code{ggplot} object
#' @export
#' @rdname stateat
#' @examples
#' plotat(mimiaka, 127)
plotat <- function(x, at, ...)
{
if (!(is.gogame(x))) stop("object is not a gogame")
stateat(x, at) %>% graphics::plot(...)
}
#' Kifu for certain move range
#' @param x \code{gogame} object
#' @param from,to Positive integers. Range of moves
#' @param restart Positive integer. If supplied, this number is used as the
#' smallest move number in the range. If not supplied, original move numbers
#' are used as they are.
#' @return \code{kifu} returns a \code{\link{gokifu}} object
#' @export
#' @examples
#' kifu(saikoyo)
kifu <- function(x, from = 1L, to = 99L, restart = NA_integer_)
{
if (!(is.gogame(x))) stop("object is not a gogame")
## 'a' is the board state before move number 'from'
## 'a' is given ismove = FALSE elsewhere, to treat as if they are
## setup moves for this kifu
## 'b' is the addition of stones between move from to to
a <- stateat(x, from-1L) %>% `[[`("board") %>%
dplyr::mutate(move = 0L, ismove = FALSE)
b <- dplyr::filter_(x$transition, ~move >= from, ~move <= to, ~value > 0L) %>%
dplyr::rename_(color = ~value)
## 'b' must have all variables in 'a'
if (!all(names(a) %in% names(b))) stop("name mismatch")
b <- b[names(a)]
a <- dplyr::bind_rows(a, b)
rm(b)
## 'coord_id' is an index that maps one-to-one with (x, y) combination
coord_id <- a$x + a$y*(x$boardsize+1)
dup <- duplicated(coord_id)
oob <- a$x < 1L | a$y < 1L | a$x > x$boardsize | a$y > x$boardsize
## for (x, y) such that duplicated and ismove,
## there should be a stone already there, hence show in the note
## coordincates out-of-bounds are also in the note
noted <- a[(dup & a$ismove) | oob, ]
## among the non-duplicated, those not ismove are either
## stone before 'from' or setup moves between 'from' and 'to'
## they should show up with no number
unnumbered <- a[(!dup & !a$ismove) & !oob, ]
## the others are to show up with numbers
numbered <- a[(!dup & a$ismove) & !oob, ]
## remaining is 'dup and !ismove' these do not show up in the kifu
## such case should not occur for valid kifu
## extract other useful information
## extract comment for the specified move range in the kifu
comment <- dplyr::filter_(x$comment, ~move >= from, ~move <= to)
## replace the move numbers by the specified first number
## this is probably useful to show off-path variation
if (!is.na(restart)) {
moves <- c(numbered$move, noted$move)
if (length(moves) > 0L) {
deviation <- min(moves) - restart
numbered$move <- numbered$move - deviation
noted$move <- noted$move - deviation
}
}
out <- gokifu(unnumbered = unnumbered, numbered = numbered, noted = noted,
boardsize = x$boardsize, comment = comment)
return(out)
}
#' @param ... graphic parameters
#' @return \code{kifuplot} returns a \code{\link{ggkifu}} object
#' @export
#' @rdname kifu
#' @examples
#' kifuplot(mimiaka, 127, 150)
kifuplot <- function(x, from = 1L, to = 99L, restart = NA_integer_, ...)
{
# one line wrapper for kifu -> plot
if (!(is.gogame(x))) stop("object is not a gogame")
kifu(x, from = from, to = to, restart = restart) %>% graphics::plot(...)
}
#' Switch path of go game
#' @description Switch path of a go game. Paths are indexed by integers starting
#' at one. If pathid exceeds the number of paths stored in the game, the function
#' throws an error.
#' @param x \code{gogame} object
#' @param pathid integer
#'
#' @return \code{gogame} object
#' @export
set_gamepath <- function(x, pathid = 1L)
{
if (!(is.gogame(x))) stop("object is not a gogame")
if (pathid > length(x$gametree$leaf)) {
mess <- c("this game has only ", length(x$gametree$leaf), " game path")
if (length(x$gametree$leaf) > 1) mess[3] <- " paths"
stop(paste0(mess, collapse = ""))
}
nodes <- get_branchpath(x$gametree$parent, x$gametree$leaf[pathid])
x$transition <- dplyr::filter_(x$gametree$transition, ~nodeid %in% nodes) %>%
dplyr::arrange_(~move)
#x$move <- dplyr::filter_(x$gametree$move, ~nodeid %in% nodes) %>%
# dplyr::arrange_(~move)
x$point <- dplyr::filter_(x$gametree$point, ~nodeid %in% nodes) %>%
dplyr::arrange_(~move)
x$comment <- dplyr::filter_(x$gametree$comment, ~nodeid %in% nodes) %>%
dplyr::arrange_(~move)
## store the current branch id
x$pathid <- as.integer(pathid)
## store the number of variations
x$npath <- length(x$gametree$leaf)
return(x)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.