internals: S3 cleaning

- drop [ and [<- method in fpstruct - review and update test-keep-next - export method as advised by new roxygen
davidgohel · Feb 21, 2024 · c633aa3 · c633aa3
1 parent c214b8e
commit c633aa3
Show file tree

Hide file tree

Showing 106 changed files with 382 additions and 360 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: flextable
 Type: Package
 Title: Functions for Tabular Reporting
-Version: 0.9.5.008
+Version: 0.9.5.009
 Authors@R: c(
     person("David", "Gohel", role = c("aut", "cre"),
     email = "[email protected]"),
@@ -35,7 +35,7 @@ Imports:
     rmarkdown, knitr, htmltools, rlang, ragg,
     officer (>= 0.6.2), gdtools (>= 0.3.3), 
     xml2, data.table (>= 1.13.0), uuid (>= 0.1-4)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.1
 Roxygen: list(markdown = TRUE)
 Suggests: 
     testthat (>= 2.1.0),

diff --git a/NAMESPACE b/NAMESPACE
@@ -24,8 +24,20 @@ S3method(dim,flextable)
 S3method(dim,flextableGrob)
 S3method(drawDetails,flextableHighlightedGrob)
 S3method(drawDetails,flextableRowPartGrob)
+S3method(format_fun,Date)
+S3method(format_fun,POSIXt)
+S3method(format_fun,character)
+S3method(format_fun,default)
+S3method(format_fun,double)
+S3method(format_fun,factor)
+S3method(format_fun,integer)
+S3method(format_fun,logical)
+S3method(format_fun,pct)
 S3method(knit_print,flextable)
 S3method(knit_print,run_reference)
+S3method(latex_container_str,latex_container_float)
+S3method(latex_container_str,latex_container_none)
+S3method(latex_container_str,latex_container_wrap)
 S3method(makeContext,flextableGrob)
 S3method(ph_with,flextable)
 S3method(plot,flextable)

diff --git a/R/01_fpstruct.R b/R/01_fpstruct.R
@@ -9,10 +9,6 @@ fpstruct <- function(nrow, keys, default) {
   class(x) <- "fpstruct"
   x
 }
-`[<-.fpstruct` <- function(x, i, j, value) {
-  x$data[i, j] <- value
-  x
-}
 
 delete_row_from_fpstruct <- function(x, i) {
   x$data <- x$data[-i, , drop = FALSE]
@@ -29,9 +25,6 @@ delete_col_from_fpstruct <- function(x, j) {
   x
 }
 
-`[.fpstruct` <- function(x, i, j) {
-  get_fpstruct_elements(x = x, i = i, j = j)
-}
 get_fpstruct_elements <- function(x, i, j) {
   if (is.null(x$data)) {
     stop("data coumpound does not exits.")
@@ -85,20 +78,23 @@ text_struct <- function(nrow, keys,
   x
 }
 
-`[<-.text_struct` <- function(x, i, j, property, value) {
+set_text_struct_values <- function(x, i, j, property, value) {
+  if (is.null(j)) j <- x$color$keys
+  if (is.null(i)) i <- seq_len(x$color$nrow)
+
   if (inherits(value, "fp_text")) {
     for (property in intersect(names(value), names(x))) {
-      x[[property]][i, j] <- value[[property]]
+      x[[property]]$data[i, j] <- value[[property]]
     }
   } else if (property %in% names(x)) {
-    x[[property]][i, j] <- value
+    x[[property]]$data[i, j] <- value
   }
 
   x
 }
-`[.text_struct` <- function(x, i, j, property, value) {
-  x[[property]][i, j]
-}
+# `[.text_struct` <- function(x, i, j, property, value) {
+#   x[[property]][i, j]
+# }
 
 delete_style_row <- function(x, i) {
   for (property in names(x)) {
@@ -113,11 +109,6 @@ delete_style_col <- function(x, j) {
   x
 }
 
-print.text_struct <- function(x, ...) {
-  dims <- dim(x$color$data)
-  cat("a text_struct with ", dims[1], " rows and ", dims[2], " columns", sep = "")
-}
-
 add_rows_to_struct <- function(x, nrows, first, ...) {
   for (i in seq_len(length(x))) {
     x[[i]] <- add_rows_fpstruct(x[[i]], nrows, first = first)
@@ -174,30 +165,23 @@ par_struct <- function(nrow, keys,
   x
 }
 
+set_par_struct_values <- function(x, i, j, property, value) {
 
-print.par_struct <- function(x, ...) {
-  dims <- dim(x$text.align$data)
-  cat("a par_struct with ", dims[1], " rows and ", dims[2], " columns", sep = "")
-}
+  if (is.null(j)) j <- x$text.align$keys
+  if (is.null(i)) i <- seq_len(x$text.align$nrow)
 
-`[<-.par_struct` <- function(x, i, j, property, value) {
   if (inherits(value, "fp_par")) {
     value <- cast_borders(value)
     for (property in intersect(names(value), names(x))) {
-      x[[property]][i, j] <- value[[property]]
+      x[[property]]$data[i, j] <- value[[property]]
     }
   } else if (property %in% names(x)) {
-    x[[property]][i, j] <- value
+    x[[property]]$data[i, j] <- value
   }
 
   x
 }
 
-
-`[.par_struct` <- function(x, i, j, property) {
-  x[[property]][i, j]
-}
-
 par_struct_to_df <- function(object, ...) {
   data <- lapply(object, function(x) {
     as.vector(x$data)
@@ -251,27 +235,6 @@ cell_struct <- function(nrow, keys,
   x
 }
 
-`[<-.cell_struct` <- function(x, i, j, property, value) {
-  if (inherits(value, "fp_cell")) {
-    value <- cast_borders(value)
-    for (property in intersect(names(value), names(x))) {
-      x[[property]][i, j] <- value[[property]]
-    }
-  } else if (property %in% names(x)) {
-    x[[property]][i, j] <- value
-  }
-
-  x
-}
-`[.cell_struct` <- function(x, i, j, property) {
-  x[[property]][i, j]
-}
-
-print.cell_struct <- function(x, ...) {
-  dims <- dim(x$background.color$data)
-  cat("a cell_struct with ", dims[1], " rows and ", dims[2], " columns", sep = "")
-}
-
 cell_struct_to_df <- function(object, ...) {
   data <- lapply(object, function(x) {
     as.vector(x$data)
@@ -337,11 +300,6 @@ add_rows_to_chunkset_struct <- function(x, nrows, first, data, ...) {
   x
 }
 
-print.chunkset_struct <- function(x, ...) {
-  dims <- dim(x$data)
-  cat("a chunkset_struct with ", dims[1], " rows and ", dims[2], " columns", sep = "")
-}
-
 as_chunkset_struct <- function(l_paragraph, keys, i = NULL) {
   if (!is.null(i) &&
       length(l_paragraph) == length(i) &&
@@ -444,11 +402,6 @@ get_chunkset_struct_element <- function(x, i, j) {
   x$data[i, j, drop = FALSE]
 }
 
-`[.chunkset_struct` <- function(x, i, j) {
-  stop("you should not see this message")
-  x$data[i, j]
-}
-
 replace_missing_fptext_by_default <- function(x, default) {
   by_columns <- c(
     "font.size", "italic", "bold", "underlined", "color", "shading.color",

diff --git a/R/border_fix.R b/R/border_fix.R
@@ -62,9 +62,9 @@ correct_h_border <- function(x) {
       i_from <- apply_bottom_border$from[i]
       i_to <- apply_bottom_border$to[i]
 
-      x$styles$cells$border.color.bottom[i_to, x$col_keys[j]] <- x$styles$cells$border.color.bottom[i_from, x$col_keys[j]]
-      x$styles$cells$border.width.bottom[i_to, x$col_keys[j]] <- x$styles$cells$border.width.bottom[i_from, x$col_keys[j]]
-      x$styles$cells$border.style.bottom[i_to, x$col_keys[j]] <- x$styles$cells$border.style.bottom[i_from, x$col_keys[j]]
+      x$styles$cells$border.color.bottom$data[i_to, x$col_keys[j]] <- x$styles$cells$border.color.bottom$data[i_from, x$col_keys[j]]
+      x$styles$cells$border.width.bottom$data[i_to, x$col_keys[j]] <- x$styles$cells$border.width.bottom$data[i_from, x$col_keys[j]]
+      x$styles$cells$border.style.bottom$data[i_to, x$col_keys[j]] <- x$styles$cells$border.style.bottom$data[i_from, x$col_keys[j]]
     }
   }
 
@@ -88,9 +88,9 @@ correct_v_border <- function(x) {
     for (j in seq_along(apply_right_border$from)) {
       colkeyto <- x$col_keys[apply_right_border$to[j]]
       colkeyfrom <- x$col_keys[apply_right_border$from[j]]
-      x$styles$cells$border.color.right[i, colkeyto] <- x$styles$cells$border.color.right[i, colkeyfrom]
-      x$styles$cells$border.width.right[i, colkeyto] <- x$styles$cells$border.width.right[i, colkeyfrom]
-      x$styles$cells$border.style.right[i, colkeyto] <- x$styles$cells$border.style.right[i, colkeyfrom]
+      x$styles$cells$border.color.right$data[i, colkeyto] <- x$styles$cells$border.color.right$data[i, colkeyfrom]
+      x$styles$cells$border.width.right$data[i, colkeyto] <- x$styles$cells$border.width.right$data[i, colkeyfrom]
+      x$styles$cells$border.style.right$data[i, colkeyto] <- x$styles$cells$border.style.right$data[i, colkeyfrom]
     }
   }
 

diff --git a/R/borders.R b/R/borders.R
@@ -82,24 +82,24 @@ border <- function(x, i = NULL, j = NULL, border = NULL,
   j <- get_columns_id(x[[part]], j)
 
   if (!is.null(border.top)) {
-    x[[part]]$styles$cells[i, j, "border.style.top"] <- border.top$style
-    x[[part]]$styles$cells[i, j, "border.color.top"] <- border.top$color
-    x[[part]]$styles$cells[i, j, "border.width.top"] <- border.top$width
+    x[[part]]$styles$cells[["border.style.top"]]$data[i, j] <- border.top$style
+    x[[part]]$styles$cells[["border.color.top"]]$data[i, j] <- border.top$color
+    x[[part]]$styles$cells[["border.width.top"]]$data[i, j] <- border.top$width
   }
   if (!is.null(border.bottom)) {
-    x[[part]]$styles$cells[i, j, "border.style.bottom"] <- border.bottom$style
-    x[[part]]$styles$cells[i, j, "border.color.bottom"] <- border.bottom$color
-    x[[part]]$styles$cells[i, j, "border.width.bottom"] <- border.bottom$width
+    x[[part]]$styles$cells[["border.style.bottom"]]$data[i, j] <- border.bottom$style
+    x[[part]]$styles$cells[["border.color.bottom"]]$data[i, j] <- border.bottom$color
+    x[[part]]$styles$cells[["border.width.bottom"]]$data[i, j] <- border.bottom$width
   }
   if (!is.null(border.left)) {
-    x[[part]]$styles$cells[i, j, "border.style.left"] <- border.left$style
-    x[[part]]$styles$cells[i, j, "border.color.left"] <- border.left$color
-    x[[part]]$styles$cells[i, j, "border.width.left"] <- border.left$width
+    x[[part]]$styles$cells[["border.style.left"]]$data[i, j] <- border.left$style
+    x[[part]]$styles$cells[["border.color.left"]]$data[i, j] <- border.left$color
+    x[[part]]$styles$cells[["border.width.left"]]$data[i, j] <- border.left$width
   }
   if (!is.null(border.right)) {
-    x[[part]]$styles$cells[i, j, "border.style.right"] <- border.right$style
-    x[[part]]$styles$cells[i, j, "border.color.right"] <- border.right$color
-    x[[part]]$styles$cells[i, j, "border.width.right"] <- border.right$width
+    x[[part]]$styles$cells[["border.style.right"]]$data[i, j] <- border.right$style
+    x[[part]]$styles$cells[["border.color.right"]]$data[i, j] <- border.right$color
+    x[[part]]$styles$cells[["border.width.right"]]$data[i, j] <- border.right$width
   }
 
   x

diff --git a/R/flextable-package.R b/R/flextable-package.R
@@ -26,4 +26,4 @@
 #' @docType package
 #' @aliases flextable-package
 #' @name flextable-package
-NULL
+"_PACKAGE"
diff --git a/R/flextable_sizes.R b/R/flextable_sizes.R
@@ -455,8 +455,14 @@ as_wide_matrix_ <- function(data, idvar, timevar = "col_key") {
 
 dim_paragraphs <- function(x) {
   par_dim <- par_struct_to_df(x$styles$pars)
-  par_dim$width <- as.vector(x$styles$pars[, , "padding.right"] + x$styles$pars[, , "padding.left"]) * (4 / 3) / 72
-  par_dim$height <- as.vector(x$styles$pars[, , "padding.top"] + x$styles$pars[, , "padding.bottom"]) * (4 / 3) / 72
+
+  par_dim$width <- as.vector(
+    x$styles$pars[["padding.right"]]$data +
+      x$styles$pars[["padding.left"]]$data) * (4 / 3) / 72
+  par_dim$height <- as.vector(
+    x$styles$pars[["padding.top"]]$data +
+      x$styles$pars[["padding.bottom"]]$data) * (4 / 3) / 72
+
   selection_ <- c(".row_id", ".col_id", "width", "height")
   par_dim[, selection_]
 
@@ -468,8 +474,8 @@ dim_paragraphs <- function(x) {
 
 dim_cells <- function(x) {
   cell_dim <- cell_struct_to_df(x$styles$cells)
-  cell_dim$width <- as.vector(x$styles$cells[, , "margin.right"] + x$styles$cells[, , "margin.left"]) * (4 / 3) / 72
-  cell_dim$height <- as.vector(x$styles$cells[, , "margin.top"] + x$styles$cells[, , "margin.bottom"]) * (4 / 3) / 72
+  cell_dim$width <- as.vector(x$styles$cells[["margin.right"]]$data + x$styles$cells[["margin.left"]]$data) * (4 / 3) / 72
+  cell_dim$height <- as.vector(x$styles$cells[["margin.top"]]$data + x$styles$cells[["margin.bottom"]]$data) * (4 / 3) / 72
   selection_ <- c(".row_id", ".col_id", "width", "height")
   cell_dim <- cell_dim[, selection_]
 

diff --git a/R/format_fun.R b/R/format_fun.R
@@ -2,6 +2,7 @@ format_fun <- function(x, ...) {
   UseMethod("format_fun")
 }
 
+#' @export
 format_fun.default <-
   function(x,
            na_str = flextable_global$defaults$na_str,
@@ -70,6 +71,7 @@ format_fun.default <-
     out
   }
 
+#' @export
 format_fun.character <-
   function(x,
            na_str = flextable_global$defaults$na_str,
@@ -81,6 +83,7 @@ format_fun.character <-
     out
   }
 
+#' @export
 format_fun.factor <-
   function(x,
            na_str = flextable_global$defaults$na_str,
@@ -92,6 +95,7 @@ format_fun.factor <-
     out
   }
 
+#' @export
 format_fun.logical <-
   function(x,
            na_str = flextable_global$defaults$na_str,
@@ -129,6 +133,7 @@ format_fun_defaultnum <-
     out
   }
 
+#' @export
 format_fun.double <-
   function(x,
            na_str = flextable_global$defaults$na_str,
@@ -149,6 +154,7 @@ format_fun.double <-
     out[is.nan(x)] <- nan_str
     out
   }
+#' @export
 format_fun.pct <-
   function(x,
            na_str = flextable_global$defaults$na_str,
@@ -173,6 +179,7 @@ format_fun.pct <-
     out
   }
 
+#' @export
 format_fun.integer <-
   function(x,
            na_str = flextable_global$defaults$na_str,
@@ -189,6 +196,7 @@ format_fun.integer <-
     out
   }
 
+#' @export
 format_fun.Date <-
   function(x,
            na_str = flextable_global$defaults$na_str,
@@ -201,6 +209,7 @@ format_fun.Date <-
     out
   }
 
+#' @export
 format_fun.POSIXt <-
   function(x,
            na_str = flextable_global$defaults$na_str,

diff --git a/R/latex_str.R b/R/latex_str.R
@@ -467,13 +467,18 @@ latex_container_wrap <- function(placement = "l") {
 latex_container_str <- function(x, latex_container, quarto = FALSE, ...) {
   UseMethod("latex_container_str", latex_container)
 }
+
+#' @export
 latex_container_str.latex_container_none <- function(x, latex_container, quarto = FALSE, ...) {
   c("", "")
 }
 
+#' @export
 latex_container_str.latex_container_float <- function(x, latex_container, quarto = FALSE, ...) {
   c("\\begin{table}", "\\end{table}")
 }
+
+#' @export
 latex_container_str.latex_container_wrap <- function(x, latex_container, quarto = FALSE, ...) {
   str <- paste0("\\begin{wraptable}{", latex_container$placement, "}")