Merge pull request #200 from Merck/develop-function-to-return-empty-t…

…able

Develop a function to return empty table

R/avg.R

@@ -47,68 +47,86 @@ avg_event <- function(id, group, par = NULL) {
     db <- data.frame(id = id, group = group)
     res <- table(db$id, db$group)
     res <- data.frame(res)
-    avg <- vapply(split(res, res$Var2),
-      function(x) mean(x$Freq, na.rm = TRUE),
-      FUN.VALUE = numeric(1)
-    )
-    se <- vapply(split(res, res$Var2),
-      function(x) sd(x$Freq, na.rm = TRUE) / sqrt(nrow(x)),
-      FUN.VALUE = numeric(1)
-    )
-    count <- vapply(split(res, res$Var2),
-      function(x) sum(x$Freq, na.rm = TRUE),
-      FUN.VALUE = numeric(1)
-    )
+    if (!nrow(res) == 0) {
+      avg <- vapply(split(res, res$Var2),
+        function(x) mean(x$Freq, na.rm = TRUE),
+        FUN.VALUE = numeric(1)
+      )
+      se <- vapply(split(res, res$Var2),
+        function(x) sd(x$Freq, na.rm = TRUE) / sqrt(nrow(x)),
+        FUN.VALUE = numeric(1)
+      )
+      count <- vapply(split(res, res$Var2),
+        function(x) sum(x$Freq, na.rm = TRUE),
+        FUN.VALUE = numeric(1)
+      )
+    } else {
+      avg <- vapply(u_group, function(x) {
+        c(x = NA)
+      }, FUN.VALUE = numeric(1))
+      se <- vapply(u_group, function(x) {
+        c(x = NA)
+      }, FUN.VALUE = numeric(1))
+      count <- vapply(u_group, function(x) {
+        c(x = 0)
+      }, FUN.VALUE = numeric(1))
+    }
   } else {
     db <- data.frame(id = id, group = group, par = par)
 
-    # Count number of observations per group, par, and id
-    tmp <- split(db, ~ group + par + id, drop = TRUE) |>
-      lapply(FUN = function(X) {
-        data.frame(
-          group = unique(X$group),
-          par = unique(X$par),
-          n = nrow(X)
-        )
-      }) |>
-      do.call(what = rbind) |>
-      split(~ group + par, drop = TRUE) |>
-      lapply(FUN = function(X) {
-        data.frame(
-          group = unique(X$group),
-          par = unique(X$par),
-          avg = mean(X$n, na.rm = TRUE),
-          se = sd(X$n, na.rm = TRUE) / sqrt(nrow(X)),
-          count = sum(X$n)
-        )
-      }) |>
-      do.call(what = rbind) |>
-      # Spread to wide format so that group.statistics are column variables
-      reshape(timevar = "group", idvar = "par", direction = "wide", new.row.names = NULL)
-
-    # Sort the summarized data so that par is in the same order as input
-    tmp <- merge(data.frame(par = unique(db$par)), tmp, by = "par", sort = TRUE)
-
-    # Remove row names
-    rownames(tmp) <- NULL
-
-    # Extract avg and se into separate datasets
-    avg <- tmp[, grepl(names(tmp), pattern = "^avg")]
-    names(avg) <- sub(names(avg), pattern = "avg\\.", replacement = "")
-    # Reorder columns (group) to be as input
-    avg[u_group[!u_group %in% names(avg)]] <- 0
-    avg <- avg[, u_group]
-
-    se <- tmp[, grepl(names(tmp), pattern = "^se")]
-    names(se) <- sub(names(se), pattern = "se\\.", replacement = "")
-    # Reorder columns (group) to be as input
-    se[u_group[!u_group %in% names(se)]] <- NA
-    se <- se[, u_group]
-
-    count <- tmp[, grepl(names(tmp), pattern = "^count")]
-    names(count) <- sub(names(count), pattern = "count\\.", replacement = "")
-    count[u_group[!u_group %in% names(count)]] <- NA
-    count <- count[, u_group]
+    if (!nrow(db) == 0) {
+      # Count number of observations per group, par, and id
+      tmp <- split(db, ~ group + par + id, drop = TRUE) |>
+        lapply(FUN = function(X) {
+          data.frame(
+            group = unique(X$group),
+            par = unique(X$par),
+            n = nrow(X)
+          )
+        }) |>
+        do.call(what = rbind) |>
+        split(~ group + par, drop = TRUE) |>
+        lapply(FUN = function(X) {
+          data.frame(
+            group = unique(X$group),
+            par = unique(X$par),
+            avg = mean(X$n, na.rm = TRUE),
+            se = sd(X$n, na.rm = TRUE) / sqrt(nrow(X)),
+            count = sum(X$n)
+          )
+        }) |>
+        do.call(what = rbind) |>
+        # Spread to wide format so that group.statistics are column variables
+        reshape(timevar = "group", idvar = "par", direction = "wide", new.row.names = NULL)
+
+      # Sort the summarized data so that par is in the same order as input
+      tmp <- merge(data.frame(par = unique(db$par)), tmp, by = "par", sort = TRUE)
+
+      # Remove row names
+      rownames(tmp) <- NULL
+
+      # Extract avg and se into separate datasets
+      avg <- tmp[, grepl(names(tmp), pattern = "^avg")]
+      names(avg) <- sub(names(avg), pattern = "avg\\.", replacement = "")
+      # Reorder columns (group) to be as input
+      avg[u_group[!u_group %in% names(avg)]] <- 0
+      avg <- avg[, u_group]
+
+      se <- tmp[, grepl(names(tmp), pattern = "^se")]
+      names(se) <- sub(names(se), pattern = "se\\.", replacement = "")
+      # Reorder columns (group) to be as input
+      se[u_group[!u_group %in% names(se)]] <- NA
+      se <- se[, u_group]
+
+      count <- tmp[, grepl(names(tmp), pattern = "^count")]
+      names(count) <- sub(names(count), pattern = "count\\.", replacement = "")
+      count[u_group[!u_group %in% names(count)]] <- NA
+      count <- count[, u_group]
+    } else {
+      avg <- NULL
+      se <- NULL
+      count <- NULL
+    }
   }
 
   list(avg = avg, se = se, count = count)
@@ -157,39 +175,44 @@ avg_duration <- function(id, group, dur, par = NULL) {
   } else {
     db <- data.frame(id = id, group = group, dur = dur, par = par)
 
-    # summarize dur by group and par
-    tmp <- split(db, ~ group + par, drop = TRUE) |>
-      lapply(FUN = function(X) {
-        data.frame(
-          group = unique(X$group),
-          par = unique(X$par),
-          avg = mean(X$dur, na.rm = TRUE),
-          se = sd(X$dur, na.rm = TRUE) / sqrt(nrow(X))
-        )
-      }) |>
-      do.call(what = rbind) |>
-      reshape(timevar = "group", idvar = "par", direction = "wide")
-    # Sort the summarized data so that par is in the same order as input
-    tmp <- merge(data.frame(par = unique(db$par)), tmp, by = "par", sort = TRUE)
-
-    # Set row names to null
-    rownames(tmp) <- NULL
-
-    # Replace NaN to NA
-    tmp[sapply(tmp, is.nan)] <- NA
-
-    # Extract avg and se into separate datasets
-    avg <- cbind(par = tmp$par, tmp[, grepl(names(tmp), pattern = "^avg")])
-    names(avg) <- sub(names(avg), pattern = "avg\\.", replacement = "")
-    # Reorder columns (group) to be as input
-    avg[u_group[!u_group %in% names(avg)]] <- NA
-    avg <- avg[, u_group]
-
-    se <- cbind(par = tmp$par, tmp[, grepl(names(tmp), pattern = "^se")])
-    names(se) <- sub(names(se), pattern = "se\\.", replacement = "")
-    # Reorder columns (group) to be as input
-    se[u_group[!u_group %in% names(se)]] <- NA
-    se <- se[, u_group]
+    if (!nrow(db) == 0) {
+      # summarize dur by group and par
+      tmp <- split(db, ~ group + par, drop = TRUE) |>
+        lapply(FUN = function(X) {
+          data.frame(
+            group = unique(X$group),
+            par = unique(X$par),
+            avg = mean(X$dur, na.rm = TRUE),
+            se = sd(X$dur, na.rm = TRUE) / sqrt(nrow(X))
+          )
+        }) |>
+        do.call(what = rbind) |>
+        reshape(timevar = "group", idvar = "par", direction = "wide")
+      # Sort the summarized data so that par is in the same order as input
+      tmp <- merge(data.frame(par = unique(db$par)), tmp, by = "par", sort = TRUE)
+
+      # Set row names to null
+      rownames(tmp) <- NULL
+
+      # Replace NaN to NA
+      tmp[sapply(tmp, is.nan)] <- NA
+
+      # Extract avg and se into separate datasets
+      avg <- cbind(par = tmp$par, tmp[, grepl(names(tmp), pattern = "^avg")])
+      names(avg) <- sub(names(avg), pattern = "avg\\.", replacement = "")
+      # Reorder columns (group) to be as input
+      avg[u_group[!u_group %in% names(avg)]] <- NA
+      avg <- avg[, u_group]
+
+      se <- cbind(par = tmp$par, tmp[, grepl(names(tmp), pattern = "^se")])
+      names(se) <- sub(names(se), pattern = "se\\.", replacement = "")
+      # Reorder columns (group) to be as input
+      se[u_group[!u_group %in% names(se)]] <- NA
+      se <- se[, u_group]
+    } else {
+      avg <- NULL
+      se <- NULL
+    }
   }
 
   list(avg = avg, se = se)

R/empty_table.R

@@ -0,0 +1,54 @@
+# Copyright (c) 2024 Merck & Co., Inc., Rahway, NJ, USA and its affiliates.
+# All rights reserved.
+#
+# This file is part of the metalite.ae program.
+#
+# metalite.ae is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+#' Create an empty table
+#'
+#' @inheritParams tlf_ae_specific
+#'
+#' @return r2rtf object for empty table with a title
+#'
+#' @noRd
+#'
+#' @examples
+#' library(r2rtf)
+#'
+#' empty_table(
+#'   title = "Participants With Adverse Events",
+#'   orientation = "portrait",
+#'   text_font_size = 8
+#' )
+empty_table <- function(title, orientation, text_font_size) {
+  # Create an empty table to be displayed
+  tbl <- data.frame(
+    name = c(NA, "No data to report.", NA)
+  )
+  names(tbl) <- ""
+
+  # Create an output of r2rtf object
+  rtf <- tbl |>
+    r2rtf::rtf_page(orientation = orientation) |>
+    r2rtf::rtf_title(title) |>
+    r2rtf::rtf_colheader(
+      colheader = "|",
+      text_font_size = text_font_size
+    ) |>
+    r2rtf::rtf_body(
+      text_justification = "l",
+      text_font_size = text_font_size
+    )
+}

R/extend_ae_specific.R

@@ -179,17 +179,19 @@ extend_ae_specific_duration <- function(outdata,
   }
 
   # Add a total group to display total column
-  pop_total <- pop
-  pop_total[[pop_group]] <- "Total"
-  pop <- rbind(pop, pop_total)
   if (nrow(pop) == 0) {
     levels(pop[[pop_group]]) <- c(levels(pop[[pop_group]]), "Total")
+  } else {
+    pop_total <- pop
+    pop_total[[pop_group]] <- "Total"
+    pop <- rbind(pop, pop_total)
   }
-  obs_total <- obs
-  obs_total[[obs_group]] <- "Total"
-  obs <- rbind(obs, obs_total)
   if (nrow(obs) == 0) {
     levels(obs[[obs_group]]) <- c(levels(obs[[obs_group]]), "Total")
+  } else {
+    obs_total <- obs
+    obs_total[[obs_group]] <- "Total"
+    obs <- rbind(obs, obs_total)
   }
 
   # Group information
@@ -296,17 +298,19 @@ extend_ae_specific_events <- function(outdata) {
   }
 
   # Add a total group to display total column
-  pop_total <- pop
-  pop_total[[pop_group]] <- "Total"
-  pop <- rbind(pop, pop_total)
   if (nrow(pop) == 0) {
     levels(pop[[pop_group]]) <- c(levels(pop[[pop_group]]), "Total")
+  } else {
+    pop_total <- pop
+    pop_total[[pop_group]] <- "Total"
+    pop <- rbind(pop, pop_total)
   }
-  obs_total <- obs
-  obs_total[[obs_group]] <- "Total"
-  obs <- rbind(obs, obs_total)
   if (nrow(obs) == 0) {
     levels(obs[[obs_group]]) <- c(levels(obs[[obs_group]]), "Total")
+  } else {
+    obs_total <- obs
+    obs_total[[obs_group]] <- "Total"
+    obs <- rbind(obs, obs_total)
   }
 
   # Group information

R/format_ae_specific.R

@@ -325,6 +325,11 @@ format_ae_specific <- function(outdata,
         }
       }
       res <- rbind(res_head, res_body)
+    } else {
+      # delete the last blank row if no events
+      res <- res[1:3, ]
+      outdata$order <- outdata$order[1:3]
+      soc_name <- soc_name[1:3]
     }
   }
 

R/format_ae_specific_subgroup.R

@@ -101,6 +101,7 @@ format_ae_specific_subgroup <- function(
   }
 
   # Need order column from total column for ordering properly across tables
+  tbl <- tbl[!(is.na(tbl$order)), ]
   tbl <- tbl[order(tbl$order), ]
 
   # If outdata$display_subgroup_total = FALSE, remove that part