R/final_output.R

In fdrennan/test: What the Package Does (One Line, Title Case)

#' final_output
#' @export final_output


final_output <- function(transformed_data, toi, emmeans_obj, final_contrast, power,
                         variable, save = "No") {
  final_contrast <- final_contrast %>%
    mutate(p.value = ifelse(p.value == 0, "p-value < 0.0001", p.value))
  ################################################################################
  # Generate Tables
  # Compute Summary statistic for the data on the original scale for both the
  # average and specific time point
  # Average Time
  AT_os <- transformed_data %>%
    group_by(TreatmentNew, Time) %>%
    summarize(sd = sd(get(variable))) %>%
    group_by(TreatmentNew) %>%
    summarize(se = mean(sd) / n()) %>%
    inner_join(transformed_data %>%
      group_by(TreatmentNew) %>%
      summarize(
        mean = mean(get(variable)),
        median = median(get(variable))
      ), .)
  # Specific Time pointQ

  # Need to make sure that toi matches above
  ST_os <- transformed_data %>%
    filter(Time == toi) %>%
    group_by(TreatmentNew, Time) %>%
    summarize(
      mean = mean(get(variable)),
      median = median(get(variable)),
      se = sd(get(variable)) / n()
    )

  os_together <- bind_rows(AT_os, ST_os) %>%
    arrange(TreatmentNew) %>%
    mutate(
      TreatmentNew = factor(TreatmentNew),
      Endpoint = if_else((row_number() %% 2) == 1,
        "Average", "Specific Time"
      )
    ) %>%
    select(TreatmentNew, Endpoint, mean, median, se) %>%
    arrange(TreatmentNew)
  # Back Transformation
  ST_bt <- emmeans_obj$ST %>%
    data.frame() %>%
    filter(Time == toi) %>%
    mutate(
      emmean_bt = case_when(
        power == 0 ~ exp(emmean),
        !(power %in% c(0, 1)) ~ emmean^(1 / power),
        power == 1 ~ NaN
      ),
      se_bt = case_when(
        power == 1 ~ NaN,
        power == 0 ~ exp(emmean) * SE,
        !(power %in% c(0, 1)) ~ (1 / power) * emmean^(1 / power - 1) * SE
      ),
    )
  AT_bt <- emmeans_obj$AT %>%
    data.frame() %>%
    mutate(
      emmean_bt = case_when(
        power == 0 ~ exp(emmean),
        !(power %in% c(0, 1)) ~ emmean^(1 / power),
        power == 1 ~ NaN
      ),
      se_bt = case_when(
        power == 1 ~ NaN,
        power == 0 ~ exp(emmean) * SE,
        !(power %in% c(0, 1)) ~ (1 / power) * emmean^(1 / power - 1) * SE
      ),
    )

  bt_together <- bind_rows(AT_bt, ST_bt) %>%
    arrange(TreatmentNew) %>%
    mutate(
      TreatmentNew = factor(TreatmentNew),
      Endpoint = if_else((row_number() %% 2) == 1,
        "Average", "Specific Time"
      )
    ) %>%
    select(TreatmentNew, Endpoint, emmean_bt, se_bt) %>%
    arrange(TreatmentNew)

  # LSmeans
  ST_lsmeans <- emmeans_obj$ST %>%
    data.frame() %>%
    filter(Time == toi)

  AT_lsmeans <- emmeans_obj$AT %>%
    data.frame()

  lsmeans_together <- bind_rows(AT_lsmeans, ST_lsmeans) %>%
    arrange(TreatmentNew) %>%
    mutate(
      TreatmentNew = factor(TreatmentNew),
      Endpoint = if_else((row_number() %% 2) == 1,
        "Average", "Specific Time"
      )
    ) %>%
    select(TreatmentNew, Endpoint, emmean, SE) %>%
    arrange(TreatmentNew) %>%
    rename(
      emmean_lsmeans = emmean,
      se_lsmeans = SE
    )

  # If power = 1 no transformation was conducted, otherwise we will need to add more
  # summary of the back transform data
  summary_stat <- os_together %>% inner_join(lsmeans_together)
  if (power != 1) {
    summary_stat <- summary_stat %>%
      inner_join(bt_together) %>%
      rename(
        "Transformed Mean" = emmean_bt,
        "Transformed SE" = se_bt
      ) %>%
      mutate_at(
        .vars = grep("Transformed", colnames(.), value = TRUE),
        .funs = ~ round(., 2)
      )
  }

  summary_stat <- summary_stat %>%
    data.frame() %>%
    mutate_at(.vars = grep("se", colnames(.)), .funs = ~ round(., 3)) %>%
    mutate_at(.vars = c("mean", "median", "emmean_lsmeans"), .funs = ~ round(., 2))
  tab1 <- table_1(final_contrast = final_contrast, os_together = summary_stat, toi = toi)
  tab2 <- table_2(final_contrast = final_contrast, os_together = summary_stat, toi = toi)
  tab3 <- table_3(final_contrast = final_contrast, os_together = summary_stat, toi = toi)
  empty_col <- tab1 %>% apply(2, function(a) sum(is.na(a)))
  tab1 <- tab1[, which(empty_col < nrow(tab1))] %>%
    rename(
      Treatment = TreatmentNew,
      "Original Scale Mean" = mean,
      "Original Scale Median" = median,
      "Original Scale SE" = se
    ) %>%
    select(-grep("emmean|lsmean", colnames(.), value = TRUE))
  colnames(tab1) <- gsub("\\.", " ", colnames(tab1))
  empty_col <- tab2 %>% apply(2, function(a) sum(is.na(a)))
  tab2 <- tab2[, which(empty_col < nrow(tab2))] %>%
    rename(
      Treatment = TreatmentNew,
      "Original Scale Mean" = mean,
      "Original Scale Median" = median,
      "Original Scale SE" = se
    ) %>%
    select(-grep("emmean|lsmean", colnames(.), value = TRUE))
  colnames(tab2) <- gsub("\\.", " ", colnames(tab2))
  empty_col <- tab3 %>% apply(2, function(a) sum(is.na(a)))
  tab3 <- tab3[, which(empty_col < nrow(tab3))] %>%
    rename(Treatment = TreatmentNew) %>%
    select(-grep("emmean|lsmean", colnames(.), value = TRUE))
  colnames(tab3) <- gsub("\\.", " ", colnames(tab3))


  wb <- createWorkbook()
  addWorksheet(wb = wb, sheetName = "Table 1")
  addWorksheet(wb = wb, sheetName = "Table 2")
  addWorksheet(wb = wb, sheetName = "Table 3")
  writeData(wb = wb, sheet = "Table 1", x = tab1)
  writeData(wb = wb, sheet = "Table 2", x = tab2)
  writeData(wb = wb, sheet = "Table 3", x = tab3)

  if (save == "yes") {
    saveWorkbook(wb, file = "Example.xlsx", overwrite = TRUE)
  }

  return(list(tab1 = tab1, tab2 = tab2, tab3 = tab3, power = power))
}

#' html_tables
#' @export
html_tables <- function(transformed_data, tab_list) {
  transform_table <- data.frame(
    power = c(2, 1, 0.5, 0, -0.5, -1),
    transform_name = c(
      "Squared", "Identity",
      "Square Root", "Log",
      "Inverse Square Root",
      "Inverse"
    )
  )

  trt_map <- distinct(transformed_data, Treatment, TreatmentNew)

  tab1 <- tab_list$tab1
  tab1 <- tab1[, which(apply(tab1, 2, function(a) !all(a == "")))]
  tab1 <- distinct(transformed_data, Treatment, TreatmentNew) %>%
    rename(
      "Treatment_orig" = Treatment,
      "Treatment" = TreatmentNew
    ) %>%
    inner_join(., tab1) %>%
    dplyr::select(-Treatment) %>%
    rename("Treatment" = Treatment_orig)

  tab2 <- tab_list$tab2
  tab2 <- tab2[, which(apply(tab2, 2, function(a) !all(a == "")))]
  tab2 <- distinct(transformed_data, Treatment, TreatmentNew) %>%
    rename(
      "Treatment_orig" = Treatment,
      "Treatment" = TreatmentNew
    ) %>%
    arrange(Treatment) %>%
    inner_join(., tab2) %>%
    dplyr::select(-Treatment) %>%
    rename("Treatment" = Treatment_orig)

  tab3 <- tab_list$tab3
  tab3 <- tab3[, which(apply(tab3, 2, function(a) !all(a == "")))]
  tab3 <- distinct(transformed_data, Treatment, TreatmentNew) %>%
    rename(
      "Treatment_orig" = Treatment,
      "Treatment" = TreatmentNew
    ) %>%
    inner_join(., tab3) %>%
    dplyr::select(-Treatment) %>%
    rename("Treatment" = Treatment_orig)

  colnames(tab1) <- gsub("p value", "p value", colnames(tab1))
  colnames(tab2) <- gsub("p value", "p value", colnames(tab2))
  colnames(tab3) <- gsub("p value", "p value", colnames(tab3))
  colnames(tab1) <- gsub("Difference", "Difference (95% CI)", colnames(tab1))
  colnames(tab2) <- gsub("Difference", "Difference (95% CI)", colnames(tab2))
  colnames(tab3) <- gsub("Difference", "Difference (95% CI)", colnames(tab3))
  power <- tab_list$power
  transform <- transform_table$transform_name[transform_table$power == power]

  footer <- if_else(substr(x = transform, start = 1, stop = 1) %in% c("A", "E", "I", "O", "U"),
    if_else(substr(x = transform, start = 1, stop = 2) == "Id",
      "No transformation was applied to the data. Difference and CI are estimated using model based LSmean.",
      paste("An", transform, "was applied to these data. Difference and CI are estimated using model based LSmean.")
    ),
    paste("A", transform, "was applied to these data")
  )
  if (!any(grepl("Transformed", colnames(tab1)))) {
    group <- unique(word(colnames(tab1)[6:ncol(tab1)], -1))
    group <- map_chr(.x = group, .f = ~ {
      tmp <- trt_map %>% filter(TreatmentNew == .x)
      as.character(tmp$Treatment)
    })
    colnames(tab1)[6:ncol(tab1)] <- gsub(" from.*", "", colnames(tab1)[6:ncol(tab1)])
    tab1HTML <- tableHTML(tab1,
      rownames = FALSE, spacing = "15px 15px",
      second_headers = list(
        c(2, 3, rep(2, length(group))),
        c("", "Summary Statistics", paste("vs.", group))
      ),
      caption = "Comparison between Controls and Wild Type",
      footer = footer
    )
  } else {
    group <- unique(word(colnames(tab1)[8:ncol(tab1)], -1))
    group <- map_chr(.x = group, .f = ~ {
      tmp <- trt_map %>% filter(TreatmentNew == .x)
      as.character(tmp$Treatment)
    })
    colnames(tab1)[8:ncol(tab1)] <- gsub(" from.*", "", colnames(tab1)[8:ncol(tab1)])
    tab1HTML <- tableHTML(tab1,
      rownames = FALSE, spacing = "15px 15px",
      second_headers = list(
        c(2, 3, 2, rep(2, length(group))),
        c(
          "", "Summary Statistics", "Transformed summary Statistics",
          paste("vs.", group)
        )
      ),
      caption = "Comparison between Controls and Wild Type",
      footer = footer
    )
  }

  if (!any(grepl("Transformed", colnames(tab2)))) {
    group <- c()
    for (i in seq(6, ncol(tab2), 2)) {
      group <- c(group, paste(word(colnames(tab2)[i], -c(2, 1)), collapse = " "))
    }
    group <- map_chr(.x = group, .f = ~ {
      tmp <- trt_map %>% filter(TreatmentNew == .x)
      as.character(tmp$Treatment)
    })
    colnames(tab2)[6:ncol(tab2)] <- gsub(" from.*", "", colnames(tab2)[6:ncol(tab2)])
    tab2HTML <- tableHTML(tab2,
      rownames = FALSE, spacing = "15px 15px",
      second_headers = list(
        c(2, 3, rep(2, length(group))),
        c("", "Summary Statistics", paste("vs.", group))
      ),
      caption = "Comparison between Treatments and Vehicle",
      footer = footer
    )
  } else {
    group <- c()
    for (i in seq(8, ncol(tab2), 2)) {
      group <- c(group, paste(word(colnames(tab2)[i], -c(2, 1)), collapse = " "))
    }
    group <- map_chr(.x = group, .f = ~ {
      tmp <- trt_map %>% filter(TreatmentNew == .x)
      as.character(tmp$Treatment)
    })
    colnames(tab2)[8:ncol(tab2)] <- gsub(" from.*", "", colnames(tab2)[8:ncol(tab2)])
    tab2HTML <- tableHTML(tab2,
      rownames = FALSE, spacing = "15px 15px",
      second_headers = list(
        c(2, 3, 2, rep(2, length(group))),
        c(
          "", "Summary Statistics", "Transformed summary Statistics",
          paste("vs.", group)
        )
      ),
      caption = "Comparison between Treatments and Vehicle",
      footer = footer
    )
  }

  # browser()
  group <- c()
  for (i in seq(3, ncol(tab3), 2)) {
    group <- c(group, paste(word(colnames(tab3)[i], -c(2, 1)), collapse = " "))
  }
  group <- map_chr(.x = group, .f = ~ {
    tmp <- trt_map %>% filter(TreatmentNew == .x)
    as.character(tmp$Treatment)
  })
  colnames(tab3)[3:ncol(tab3)] <- gsub(" from.*", "", colnames(tab3)[3:ncol(tab3)])
  tab3HTML <- tableHTML(tab3,
    rownames = FALSE, spacing = "15px 15px",
    second_headers = list(
      c(2, rep(2, length(group))),
      c("", paste("vs.", group))
    ),
    caption = "Comparison between Treatments and Controls/Wild Type",
    footer = footer
  )
  # browser()
  return(list(tab1HTML, tab2HTML, tab3HTML))
}