Import functions from ryser-in-r. (#21)

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: keedwell
 Title: Latin Squares in R
-Version: 0.1.1
+Version: 0.1.1.9000
 Authors@R: 
     person("Matthew", "Henderson", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-7949-8208"))

NAMESPACE

@@ -1,7 +1,13 @@
 # Generated by roxygen2: do not edit by hand
 
+export(add_cols)
 export(add_rows)
 export(create_latin_square)
 export(edge_tbl)
+export(next_col_matching)
+export(next_col_random)
 export(next_row)
+export(next_row_matching)
+export(next_row_random)
 export(to_tidygraph)
+export(to_tidygraph_2)

R/add-cols.R

@@ -0,0 +1,20 @@
+#' Add new columns to a latin rectangle
+#'
+#' @param R A latin rectangle
+#' @param cols Indices of columns to add
+#' @param l_order Dimension of latin square
+#' @param strategy Strategy for filling columns
+#'
+#' @return A latin rectangle
+#' @export
+add_cols <- function(R, cols, l_order, strategy = next_col_matching) {
+
+  for (i in cols) {
+
+    R <- strategy(R, i, l_order)
+
+  }
+
+  return(R)
+
+}

R/edge-tbl.R

@@ -29,5 +29,31 @@ edge_tbl <- function(R, i, l_order = 3) {
   ) |>
     dplyr::mutate(from = paste0("c", i))
 
+  return(edge_df)
+}
+
+#' Symbols missing from rows data frame
+#'
+#' @param R latin rectangle
+#' @param i row index
+#' @param l_order size of latin square R is going to be embedded into
+#'
+#' @return The edge data frame.
+edge_tbl_2 <- function(R, i, l_order = 3) {
+
+  all_symbols <- 1:l_order
+
+  # symbols used in row i
+  used <- R |> dplyr::filter(row == i) |> dplyr::pull(symbol)
+
+  # symbols missing from row i
+  missing <- setdiff(all_symbols, used)
+
+  # edge data frame for column i
+  edge_df <- tibble::tibble(
+    to = paste0("s", missing)
+  ) |>
+    dplyr::mutate(from = paste0("r", i))
+
   return(edge_df)
 }

R/next-col.R

@@ -0,0 +1,69 @@
+#' Matching strategy for adding new columns
+#'
+#' @param R a latin rectangle
+#' @param i column index
+#' @param l_order dimension
+#'
+#' @return a latin rectangle with more columns
+#' @export
+next_col_matching <- function(R, i, l_order) {
+
+  n_rows <- max(R$row)
+  n_cols <- max(R$column)
+
+  bg <- to_tidygraph_2(R, l_order, n_rows, n_cols)
+
+  m <- igraph::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]
+    ) |>
+    dplyr::filter(from <= n_rows)
+
+  # just the matching itself, as a graph
+  mg <- bg |>
+    tidygraph::activate(edges) |>
+    dplyr::filter(matching)
+
+  EE <- igraph::ends(mg, igraph::E(mg))
+
+  R |>
+    dplyr::bind_rows(
+      tibble::tibble(
+        column = rep(i, n_rows),
+        row = 1:n_rows,
+        symbol = as.numeric(gsub("s", "", EE[, 2]))
+      )
+    )
+
+}
+
+#' Random strategy for choosing a new columns
+#'
+#' @param R a latin rectangle
+#' @param i column index
+#' @param l_order dimension
+#'
+#' @return A latin rectangle with more columns
+#' @export
+next_col_random <- function(R, i, l_order) {
+
+  n_rows <- max(R$row)
+  n_cols <- max(R$column)
+
+  R |>
+    dplyr::bind_rows(
+      tibble::tibble(
+        column = rep(i, n_rows),
+        row = 1:n_rows,
+        symbol = sample(1:l_order, n_rows)
+      )
+    )
+
+}

R/next-row.R

@@ -36,4 +36,74 @@ next_row <- function(R, l_order) {
 
   EE <- igraph::ends(mg, igraph::E(mg))
   return(as.numeric(gsub("s", "", EE[,2])))
-}
+}
+
+#' Find a random new row for a latin rectangle
+#'
+#' @param R A latin rectangle
+#' @param i Number of columns to add
+#' @param l_order Order of R
+#'
+#' @return A latin square with more rows.
+#' @export
+next_row_random <- function(R, i, l_order) {
+
+  R |>
+    dplyr::bind_rows(
+      tibble::tibble(
+        row = rep(i, l_order),
+        column = 1:l_order,
+        symbol = sample(1:l_order, l_order)
+      )
+    )
+
+}
+
+#' 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 A latin rectangle
+#' @param i Number of columns to add
+#' @param l_order Order of R
+#'
+#' @return A latin rectangle with more rows.
+#' @export
+next_row_matching <- function(R, i, l_order) {
+  bg <- to_tidygraph(R, l_order)
+
+  m <- igraph::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 <- igraph::ends(mg, igraph::E(mg))
+
+  R |>
+    dplyr::bind_rows(
+      tibble::tibble(
+        row = rep(i, l_order),
+        column = 1:l_order,
+        symbol = as.numeric(gsub("s", "", EE[,2]))
+      )
+    )
+}

R/to-tidygraph.R

@@ -29,4 +29,44 @@ to_tidygraph <- function(R, l_order = 3) {
 
   tidygraph::tbl_graph(nodes = l_nodes, edges = l_edges)
 
-}
+}
+
+#' Symbols missing from rows bipartite graph
+#'
+
+#' @param R A latin rectangle.
+#' @param l_order Order of R.
+#' @param n_rows Number of rows.
+#' @param n_cols Number of columns.
+#'
+#' @return A bipartite graph.
+#' @export
+to_tidygraph_2 <- function(R, l_order, n_rows, n_cols) {
+
+  ## VERTEX DATA FRAME
+  row_vertices <- paste0("r", 1:n_rows)
+  symbol_vertices <- paste0("s", 1:l_order)
+
+  n_dummy_nodes <- l_order - n_rows
+  dummy_vertices <- paste0("d", 1:n_dummy_nodes)
+
+  l_nodes <- tibble::tibble(
+    name = c(row_vertices, dummy_vertices, symbol_vertices),
+    type = c(rep(TRUE, n_rows + n_dummy_nodes), rep(FALSE, l_order))
+  )
+
+  ## EDGE DATA FRAME
+  f <- function(i) return(edge_tbl_2(R, i, l_order))
+
+  l_edges <- purrr::map_df(1:n_rows, f)
+
+  G <- tidygraph::tbl_graph(nodes = l_nodes, edges = l_edges)
+
+  d_edges <- tibble::tibble(
+    to = rep(symbol_vertices, as.numeric(l_order - n_cols - igraph::degree(G, symbol_vertices))),
+    from = rep(dummy_vertices, each = l_order - n_cols)
+  )
+
+  tidygraph::tbl_graph(nodes = l_nodes, edges = dplyr::bind_rows(l_edges, d_edges))
+
+}