Merge pull request #4 from MHenderson/3-import-functions-from-mhall-in-r

Import functions from mhall-in-r

DESCRIPTION

@@ -9,3 +9,9 @@ License: MIT + file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.1
+Imports:
+  dplyr,
+  purrr,
+  tibble,
+  tidygraph,
+  tidyr

R/add-rows.R

@@ -0,0 +1,39 @@
+#' Embed latin rectangle in a latin square
+#'
+#' Input is a latin rectangle as a data frame with
+#' variables for row, column and symbol. Output is
+#' a latin square in the same format which contains
+#' the given latin rectangle in the first rows.
+#'
+#' Use can optionally provide a vector of row indices.
+#' Only those rows will be filled if that optional
+#' vector is provided.
+#'
+#' @param R latin rectangle
+#' @param rows empty rows to be filled
+#'
+#' @return
+#' @export
+#'
+#' @examples
+add_rows <- function(R, rows) {
+
+  # we assume that the dimension equals
+  # the number of columns
+  l_order <- length(unique(R$column))
+
+  for (i in rows) {
+
+    R <- R |>
+      dplyr::bind_rows(
+        tibble::tibble(
+             row = rep(i, l_order),
+          column = 1:l_order,
+          symbol = next_row(R, l_order)
+        )
+      )
+
+  }
+
+  return(R)
+}

R/create-latin-square.R

@@ -0,0 +1,17 @@
+#' Generate latin squares
+#'
+#' Create a latin square by first generating a
+#' 1 x l_order latin rectangle and then embedding
+#' it in a latin square.
+#'
+#' @param l_order
+#'
+#' @return
+#' @export
+#'
+#' @examples
+create_latin_square <- function(l_order) {
+  tidyr::expand_grid(row = 1:1, column = 1:l_order) |>
+  dplyr::mutate(symbol = 1:l_order) |>
+  embedding(l_order = l_order, rows = 2:l_order)
+}

R/edge-tbl.R

@@ -0,0 +1,35 @@
+#' Symbols missing from columns edge data frame
+#'
+#' Constructs a data frame representing the edges
+#' of a bipartite graph based on a latin rectangle
+#' where the graph has an edge for every symbol not
+#' already used in a column.
+#'
+#' Acutally, this is just for one column.
+#'
+#' @param R latin rectangle
+#' @param i column
+#' @param l_order size of latin square R is going to be embedded into
+#'
+#' @return
+#' @export
+#'
+#' @examples
+edge_tbl <- function(R, i, l_order = 3) {
+
+  all_symbols <- 1:l_order
+
+  # symbols used in column i
+  used <- R |> dplyr::filter(column == i) |> dplyr::pull(symbol)
+
+  # symbols missing from column i
+  missing <- setdiff(all_symbols, used)
+
+  # edge data frame for column i
+  edge_df <- tibble::tibble(
+    to = paste0("s", missing)
+  ) |>
+    dplyr::mutate(from = paste0("c", i))
+
+  return(edge_df)
+}

R/next-row.R

@@ -0,0 +1,41 @@
+#' Find a compatible row for extending a latin rectangle
+#'
+#' Given an input latin rectangle this function will
+#' generate a new row that can be added to the latin
+#' rectangle.
+#'
+#' The method used is to create a bipartite graph
+#' with vertex partitions for columns and symbols
+#' missing from columns and then find a maximum
+#' matching in that bipartite graph.
+#'
+#' @param R
+#' @param l_order
+#'
+#' @return
+#' @export
+#'
+#' @examples
+next_row <- function(R, l_order) {
+  bg <- to_tidygraph(R, l_order)
+
+  m <- max_bipartite_match(bg)
+
+  # names of edges in the matching
+  matching_names <- match(m$matching, names(m$matching))
+
+  # add a matching indicator to the edges
+  bg <- bg |>
+    tidygraph::activate(edges) |>
+    dplyr::mutate(
+      matching = to == matching_names[from]
+    )
+
+  # just the matching itself, as a graph
+  mg <- bg |>
+    tidygraph::activate(edges) |>
+    dplyr::filter(matching)
+
+  EE <- ends(mg, E(mg))
+  return(as.numeric(gsub("s", "", EE[,2])))
+}

R/to-tidygraph.R

@@ -0,0 +1,33 @@
+#' Symbols missing from columns bipartite graph
+#'
+#' Input is a latin rectangle as a data frame with
+#' variables for row, column and symbol. Output is
+#' a tidygraph representing the bipartite graph with
+#' vertices for columns and symbols and edges representing
+#' symbols missing from columns.
+#'
+#' @param R
+#'
+#' @return
+#' @export
+#'
+#' @examples
+to_tidygraph <- function(R, l_order = 3) {
+
+  ## VERTEX DATA FRAME
+  column_vertices <- paste0("c", 1:l_order)
+  symbol_vertices <- paste0("s", 1:l_order)
+
+  l_nodes <- tibble::tibble(
+    name = c(column_vertices, symbol_vertices),
+    type = c(rep(TRUE, l_order), rep(FALSE, l_order))
+  )
+
+  ## EDGE DATA FRAME
+  f <- function(i) return(edge_tbl(R, i, l_order))
+
+  l_edges <- purrr::map_df(1:l_order, f)
+
+  tidygraph::tbl_graph(nodes = l_nodes, edges = l_edges)
+
+}

keedwell.Rproj

@@ -15,3 +15,5 @@ LaTeX: pdfLaTeX
 BuildType: Package
 PackageUseDevtools: Yes
 PackageInstallArgs: --no-multiarch --with-keep.source
+
+UseNativePipeOperator: Yes