R/functions_graph.R

In shigono/rSlidePzl: Analyze sliding puzzles

plotGraph <- function(g, state_label = FALSE, state_status = TRUE, state_color = c("blue", "skyblue",
    "gray", "red"), move_label = TRUE, method = "igraph", community = NULL, weight_in_community = 5,
    fr_iter = 1000, ...) {
    #' plot a network graph
    #'
    #' provide an easy way to plot a network graph returned by \code{makeGraph} function.
    #'
    #' To plot with more detailed specification, use \code{igraph::tkplot} or
    #' \code{GGally::ggnet2} function instead.
    #' For huge graphs consider to use other software like Gephi.
    #'
    #' see \code{\link{makeGraph}} for example code.
    #'
    #' @export
    #' @param g an object  generated by \code{makeGraph} function.
    #' @param state_label  Labels of states. It can be one of follows:
    #'                     \itemize{
    #'                     \item a vector, of which length is the number of vertexs in \code{g},
    #'                           giving labels.
    #'                     \item \code{TRUE}, which specifies \code{V(g)$name} as labels.
    #'                     \item \code{FALSE}, which means no label.
    #'                     }
    #'
    #' @param state_status Status of states. It can be one of follows:
    #'                     \itemize{
    #'                     \item an integer vector, of which length is the number of vertex
    #'                     in \code{g}, giving status.
    #'                     \item \code{TRUE}, which specifies \code{V(g)$status} as status.
    #'                     \item \code{FALSE}, which means no status.
    #'                     }
    #' @param state_color  a vector of color names.
    #'                     The ith state is colored by \code{state_color[state_status[i]]}.
    #' @param move_label   Labels of moves. It can be one of follows:
    #'                     \itemize{
    #'                     \item a vectorm of which length is the number of edges in \code{g},
    #'                     giving labels.
    #'                     \item \code{TRUE}, which specifies \code{E(g)$name} as labels.
    #'                     \item \code{FALSE}, which means no label.
    #'                     }
    #' @param method       one of follows:
    #'                     \itemize{
    #'                     \item igraph': use \code{igraph::plot}
    #'                     \item 'GGally': use \code{GGally::ggnet2}
    #'                     }
    #' @param community    an object of 'igraph::communities' class,
    #'                     giving community of \code{g}.
    #'                     If specified, weights are assigned to edges
    #'                     so that communities are separated each other.
    #'                     It can be specified only when \code{method = 'igraph'}.
    #' @param weight_in_community weights for edges within same community.
    #'                            Bigger value makes communities to be separated much more.
    #'                            Only effective when \code{community} is specified.
    #' @param fr_iter      iteration for fruchterman reingold algorithm.
    #'                     Only effective when \code{community} is specified.
    #' @param ... pass to \code{igraph::plot} or \code{GGally::ggnet2}
    #' @importFrom igraph E
    #' @importFrom igraph V
    #' @importFrom igraph is_igraph
    #' @importFrom igraph plot.igraph
    #' @importFrom igraph crossing
    #' @importFrom igraph gorder
    #' @importFrom igraph gsize
    #' @importFrom qgraph qgraph.layout.fruchtermanreingold
    #' @importFrom GGally ggnet2

    # trap: g
    stopifnot(is_igraph(g))
    # trap: state_label
    stopifnot(length(state_label) == gorder(g) | is.logical(state_label))
    # trap: state_status
    stopifnot(length(state_status) == gorder(g) | is.logical(state_status))
    # trap: move_label
    stopifnot(length(move_label) == gsize(g) | is.logical(move_label))
    # trap: method
    stopifnot(method %in% c("igraph", "GGally"))
    # trap: community
    stopifnot(is.null(community) | "communities" %in% class(community))
    # if community is specified, method should be igraph
    stopifnot(!(!is.null(community) & (method != "igraph")))

    # convert state_label
    if (is.logical(state_label)) {
        if (state_label) {
            state_label <- V(g)$name
        } else {
            state_label <- NULL
        }
    }
    # convert state_status
    if (is.logical(state_status)) {
        if (state_status) {
            state_status <- V(g)$status
        } else {
            state_status <- NULL
        }
    }
    # convert move_label
    if (is.logical(move_label)) {
        if (move_label) {
            move_label <- E(g)$name
        } else {
            move_label <- NULL
        }
    }

    # igraph - - - - - - - - - - - - -
    if (method == "igraph") {
        if (is.null(state_label))
            status_label <- NA
        if (is.null(move_label))
            move_label <- NA

        if (!is.null(community)) {
            layout <- qgraph.layout.fruchtermanreingold(as_edgelist(g, names = FALSE), weights = ifelse(crossing(community,
                g), 1, weight_in_community), vcount = gorder(g), niter = fr_iter)
        } else {
            layout = NULL
        }

        plot.igraph(g, vertex.size = 8, vertex.color = state_color[state_status], vertex.frame.color = NA,
            vertex.label = state_label, vertex.label.size = 1, vertex.label.family = "sans", edge.arrow.size = 0.2,
            edge.arrow.width = 0.2, edge.label = move_label, edge.label.family = "sans", edge.label.cex = 1,
            edge.label.color = "black", layout = layout, ...)
    }

    # igraph - - - - - - - - - - - - -
    if (method == "GGally") {
        if (is.null(state_label))
            status_label <- FALSE
        if (is.null(move_label))
            move_label <- FALSE

        ggnet2(g, size = 6, node.alpha = 0.5, label = status_label, edge.label = move_label, edge.label.size = 4,
            arrow.size = 6, arrow.gap = 0.025, arrow.type = "closed", color = state_color[state_status])
    }
}
getAllShortestPaths <- function(g, target = NULL) {
    #' get all of shortest paths to target
    #'
    #' Get all of shortest paths from initial states to goal states
    #' (or to specified states). It may take a long time.
    #'
    #' see \code{\link{makeGraph}} for example code.
    #'
    #' @export
    #' @param g an 'igraph' object generated by \code{makeGraph} function.
    #' @param target a numerical vector, which gives
    #'               IDs of target states. NULL means IDs of goal states.
    #' @importFrom igraph all_shortest_paths
    #' @importFrom igraph E
    #' @importFrom igraph is.igraph
    #' @return a list with following elements:
    #'         \describe{
    #'           \item{state}{a list of character vectors.
    #'           ith element gives states in the ith path.}
    #'           \item{transition}{a list of character vectors.
    #'           ith element gives transitions in the ith path.}
    #'         }
    #'

    stopifnot(is.igraph(g))

    if (is.null(target)) {
        target <- seq_along(V(g))[V(g)$status == 4]
    }
    stopifnot(length(target) > 0)
    stopifnot(target %in% seq_along(V(g)))

    anDepth <- as.integer(V(g)$depth)
    anTarget <- target[anDepth == min(anDepth)]

    lPath <- all_shortest_paths(g, from = 1, to = anTarget, mode = "all")

    lState <- lapply(lPath$res, function(x) x$name)

    lMove <- lapply(lPath$res, function(nodes) {
        anStateID <- as.integer(nodes)
        mnStateID <- matrix(NA, nrow = length(anStateID) - 1, 2)
        mnStateID[, 1] <- anStateID[-length(anStateID)]
        mnStateID[, 2] <- anStateID[-1]
        E(g, P = unlist(t(mnStateID)))$name
    })

    list(state = lState, transition = lMove)
}
getShortestPath <- function(g, target = NULL) {
    #' get a shortest paths to target
    #'
    #' get one of the shortest path from initial states to goal states
    #' (or to specified states).
    #'
    #' @export
    #' @param g an 'igraph' object generated by \code{makeGraph} function.
    #' @param target a numerical vector, which gives
    #'               IDs of target states. NULL means IDs of goal states.
    #' @importFrom igraph shortest_paths
    #' @importFrom igraph E
    #' @return a list with following elements:
    #'         \describe{
    #'           \item{state}{a character vector, giving states of the path.}
    #'           \item{transition}{a character vectors,
    #'           giving transitions of the path.}
    #'         }
    #'

    stopifnot(is.igraph(g))

    if (is.null(target)) {
        target <- seq_along(V(g))[V(g)$status == 4]
    }
    stopifnot(length(target) > 0)
    stopifnot(target %in% seq_along(V(g)))

    anDepth <- as.integer(V(g)$depth)
    anTarget <- target[anDepth == min(anDepth)]

    lPath <- shortest_paths(g, from = 1, to = anTarget[1], output = "vpath")

    anStateID <- as.integer(lPath$vpath[[1]])
    mnStateID <- matrix(NA, nrow = length(anStateID) - 1, 2)
    mnStateID[, 1] <- anStateID[-length(anStateID)]
    mnStateID[, 2] <- anStateID[-1]
    asMove <- E(g, P = unlist(t(mnStateID)))$name

    list(state = lPath$vpath[[1]], transition = asMove)
}
getReachability <- function(g, target = NULL) {
    #' get reachability to goal states
    #'
    #' get reachability to goal states (or to `target` states if specified).
    #' See details.
    #'
    #' Reachability of a state represent
    #' whether it is on any acyclic path to any of goal states
    #' (or to any of `target` states if specified).
    #'
    #' Suppose you proceeded from the initial state of the sliding puzzles.
    #' \itemize{
    #' \item
    #' When your current state is 'reachable', you are on the right track.
    #' By proceeding further from there, you can
    #' achive one of goal (or `target``) states
    #' without returning states which you have already passes through
    #' (and without being interrupted by any of goal states,
    #' if `target` is specified).
    #' \item
    #' When your current state is 'unreachable', something goes wrong.
    #' By proceeding further from there you will eventually see
    #' states which you have already passes through
    #' (or will be intrrupted by any of goal states if `target` is specified) before
    #' you achive one of goal (`target`) states.
    #' }
    #'
    #' 'Reachability' of a state is a wider concept than
    #' whether it is on the shortest pathes to the goal (target) states:
    #' States on the longer pathes are also 'reachable'.
    #'
    #' @export
    #' @param g an 'igraph' object generated by \code{makeGraph} function.
    #' @param target a numerical vector, which gives
    #'               IDs of target states. NULL means IDs of goal states.
    #' @importFrom igraph is.igraph
    #' @importFrom igraph E
    #' @importFrom igraph V
    #' @importFrom igraph as_edgelist
    #' @return a binary vector of the length of the number of states in `g`.
    #'         The ith element gives reachability of the ith state in `g`
    #'         (0:unreachable, 1:reachable)

    # trap: g
    stopifnot(is.igraph(g))

    # defing target
    if (is.null(target)) {
        target <- seq_along(V(g))[V(g)$status == 4]
    }
    # trap: target
    stopifnot(length(target) > 0)
    stopifnot(target %in% seq_along(V(g)))

    anDepth <- as.integer(V(g)$depth)
    mnEdge <- as_edgelist(g, names = FALSE)

    anStateID <- seq_along(anDepth)
    out <- rep(NA, length(anDepth))

    for (nCurrentDepth in seq(max(anDepth), 0)) {

        anCurrentID <- anStateID[anDepth == nCurrentDepth]
        anNextDepthID <- anStateID[anDepth == nCurrentDepth + 1]

        anNextDepthHitID <- anNextDepthID[!is.na(out[anNextDepthID]) & out[anNextDepthID] == 1]
        anCandidate <- unique(c(mnEdge[mnEdge[, 2] %in% anNextDepthHitID, 1], target))

        stopifnot(is.na(out[anCurrentID]))
        out[anCurrentID] <- ifelse(anCurrentID %in% anCandidate, 1, 0)
    }
    stopifnot(!is.na(out))

    return(out)
}