#' Apply headers and footnotes to gt object
#'
#' Pulls headers and footnotes from the docorator object and applies them to the gt object
#' Note: this function is only for use by downstream tools and is not intended for general users
#'
#' @param x a docorator object
#'
#' @return gt object (either tbl or group)
#' @keywords internal
#'
#' @export
#' @keywords internal
#'
#' @examples
#' docorator <- gt::exibble |>
#'   gt::gt()|>
#'   as_docorator(
#'   display_name = "my_tbl",
#'   header = fancyhead(
#'   fancyrow(left = "Protocol: 12345", right = doc_pagenum()),
#'   fancyrow(center = "Demographic Summary")
#'   ),
#'   footer = NULL,
#'   save_object = FALSE)
#'
#' hf_to_gt(docorator)

hf_to_gt <- function(x) {

  if (!inherits(x, "docorator")) {
    cli::cli_abort("The {.arg {rlang::caller_arg(x)}} argument must be class docorator, not {.obj_type_friendly {x}}. See documentation for `as_docorator`.",
              call = rlang::caller_env())
  }

  gt <- x$display

  if (!rlang::inherits_any(gt, c("gt_tbl", "gt_group"))) {
    cli::cli_abort("The {.arg {rlang::caller_arg(x)}} argument must be class gt_tbl or gt_group, not {.obj_type_friendly {x}}.",
              call = rlang::caller_env())
  }

  head_foot <- hf_extract(x)

  if(inherits(gt, "gt_tbl")){
    gt <- hf_to_gt_tbl(gt, head_foot$head_data, head_foot$subhead_data, head_foot$foot_data)
  }

  return(gt)
}

#' headers and footers for gt_tbl
#' @param gt a gt object
#' @param header a character vector containing header information
#' @param subheader a character vector containing subheader information
#' @param footer a character vector containing footnote information
#'
#' @noRd
hf_to_gt_tbl <- function(gt, header, subheader, footer){
  if(inherits(gt, "gt_tbl")){

    # order of titles should be: all docorator headers (header and subheader) then gt title, then gt subtitles.
    subtitle <- NULL # will create a vector of new subtitles and split with <br> characters
    gt_headers <- NULL # vector of existing gt headers to be added at the end of docorator headers

    # check title and subtitle arent empty strings and add to gt_headers.
    if(!is.null(gt$`_heading`$title) && !identical(gt$`_heading`$title, "")){
      gt_headers <- gt$`_heading`$title
    }

    # check if existing subtitle exists, if so add to gt_headers
    if(!is.null(gt$`_heading`$subtitle) && !identical(gt$`_heading`$subtitle, "")){
      gt_headers <- c(gt_headers,gt$`_heading`$subtitle)
    }

    # add docorator subtitle text before old gt headers.
    subtitle <- c(subheader, gt_headers)

    # if not null or empty, add breaks and md()
    if(!is.null(subtitle) && !identical(subtitle,"")){
      subtitle <- gt::md(paste0(subtitle, collapse = "<br>"))
    }
    # header
    if(length(header)>0 | length(subtitle)>0){
      gt <- gt |>
        gt::tab_header(title = paste0(header, collapse = " "), subtitle = subtitle)
    }
    # footer
  if(length(footer)>0){
    for(footnote in footer){
      gt <- gt |>
        gt::tab_footnote(footnote = footnote)
    }
  }
  }
  return(gt)
}


#' extract header footer info from docorator object
#' @param x a docorator object
#'
#' @return list of header footer info
#' @keywords internal
#'
#' @export
#' @keywords internal
#' @examples
#' docorator <- gt::exibble |>
#'   gt::gt()|>
#'   as_docorator(
#'   display_name = "mytbl",
#'   header = fancyhead(
#'   fancyrow(left = "Protocol: 12345", right = doc_pagenum()),
#'   fancyrow(center = "Demographic Summary")
#'   ),
#'   footer = NULL,
#'   save_object = FALSE)
#'
#' hf_extract(docorator)
hf_extract <- function(x){
  # get header and footer information
  header <- x$header
  footer <- x$footer

  # Take titles that are alignment center, remove any missing
  # First value is title, any remaining are subtitles
  all_headers <- unlist(lapply(header, function(x){
    if(!is.na(x$center)){
      x$center
    }}))

  head_data <- all_headers[1]

  # subheaders
  if(length(all_headers[-1])>0){
    subhead_data <- all_headers[-1]
  }else{
    subhead_data <- NULL
  }

  # Take footers that are alignment left, remove any missing
  foot_data <- unlist(lapply(footer, function(x){
    if(!is.na(x$left)){
      x$left
    }}))

  list(head_data = head_data,
       subhead_data = subhead_data,
       foot_data = foot_data)

}

#' apply a gt function to a gt_group
#' @param x gt group object
#' @param func string with function name
#' @param args named list of function arguments with gt_tbl or gt_group as first arg
#' @param call caller env
#' @export
#' @examples
#' gt_tbl <- gt::exibble|> gt::gt()
#' gt_group <- gt::gt_group(gt_tbl, gt_tbl)
#'
#' func <- gt::tab_options
#' arg_list_group <- list(page.header.use_tbl_headings = c(TRUE))
#'
#' apply_to_gt_group(gt_group, func,arg_list_group)
#'
apply_to_gt_group <- function(x, func, args, call = rlang::caller_env()){

  if(!(inherits(x, c("gt_tbl", "gt_group")))){
    cli::cli_abort("First arg must be a gt_tbl or gt_group object, not {.obj_type_friendly {x}}")
  }
  # add gt to args list as first element
  full_args <- append(args, list(x), after = 0)

  if(inherits(x, "gt_tbl")){
    x <- do.call(func, full_args, envir = call)
  }else if(inherits(x, "gt_group")){
    for (i in seq_len(nrow(x$gt_tbls))) {
      # pull out gt_tbl, apply function, reinsert into group
      gt_tbl <- gt::grp_pull(x, i)
      # replace data arg with current gt_tbl
      full_args[[1]] <- gt_tbl
      #make it clear which table if an error occurs
      gt_tbl <- tryCatch({
        do.call(func, full_args, envir = call)
      },
      error = function(e) {
        cli::cli_abort("Failure in Table {i}", parent = e)
      })

      x <- gt::grp_replace(x, gt_tbl, .which = i)
    }
  }

  x
}

#' Convert png object to gt from docorator object
#' @param x docorator object
#' @noRd
#' @keywords internal
png_to_gt <- function(x){

  # save png to temp file
 temp_png <- tempfile(
    pattern = "temp_png_",
    tmpdir = tempdir(),
    fileext = ".png")

 png::writePNG(x$display$png, temp_png)

  # convert to gt
  gt <- dplyr::tibble(ggplot =  temp_png) |>
    gt::gt() |>
    gt::fmt_image(columns = dplyr::everything(), sep = ",", height = paste0(x$fig_dim[1], "in"), width = paste0(x$fig_dim[2], "in")) |>
    # remove column headers and borders
    gt::tab_options(
      column_labels.hidden = TRUE,
      table.border.top.style = "hidden",
      table.border.bottom.style = "hidden"
    )

  gt

}

#' Convert ggplot object to gt from docorator object
#' @param x docorator object
#' @noRd
#' @keywords internal
gg_to_gt <- function(x){

  if (!inherits(x$display, "ggplot")) {
    cli::cli_abort("The display must be class `ggplot`, not {.obj_type_friendly {x$display}}.",
                   call = rlang::caller_env())
  }

  # remove header footer information
  display_info <- hf_strip(x$display)

  # convert to gt
  gt <- dplyr::tibble(ggplot =  display_info$display |>
                 gg_to_image(fig_dim = x$fig_dim, path = tempdir())) |>
    gt::gt() |>
    gt::fmt_image(columns = dplyr::everything(), sep = ",", width = "6in") |>
    # add header and footer information
    gt::tab_header(title = display_info$head_data, subtitle = display_info$subhead_data) |>
    # remove column headers and borders
    gt::tab_options(
      column_labels.hidden = TRUE,
      table.border.top.style = "hidden",
      table.border.bottom.style = "hidden"
    )

  # add footnotes if not NULL - avoids null row being added
  if(!is.null(display_info$foot_data)){
    gt <- gt |>
      gt::tab_footnote(footnote = display_info$foot_data)
  }

  gt

}

#' ggplot to image filepath
#' Taken from code here: https://github.com/rstudio/gt/blob/6312cf5be92fae41633b5df7d41aa948b850aaf8/R/image.R#L351C1-L392C2
#' @param plot_object ggplot object
#' @param fig_dim vector containing figure height and width in inches. Defaults to c(5,8) - docorator defaults
#' @param path file path including the png location to save the output to
#' @return filepath to snap of ggplot
#' @keywords internal
#' @noRd
gg_to_image <- function(plot_object, fig_dim = c(5,8), path = NULL) {


  # Upgrade x to a list if only a single ggplot object is provided
  if (inherits(plot_object, "gg")) {
    plot_object <- list(plot_object)
  }

  vapply(
    seq_along(plot_object),
    FUN.VALUE = character(1L),
    USE.NAMES = FALSE,
    FUN = function(x) {

      filename <- tempfile(
        pattern = "temp_gt_ggplot_",
        tmpdir = path,
        fileext = ".png")

      # Save PNG file to disk
      ggplot2::ggsave(
        filename = filename,
        create.dir = TRUE,
        plot = plot_object[[x]],
        device = "png",
        dpi = 300,
        width = fig_dim[2],
        height = fig_dim[1],
        units = "in"
      )

      filename

    }
  )
}

#' strip header footer info from ggplot object
#' @param x a ggplot object
#'
#' @return list of header footer info
#'
#' @noRd
#' @keywords internal
hf_strip <- function(x){


  if (!inherits(x, "ggplot")) {
    cli::cli_abort("The display must be class `ggplot`, not {.obj_type_friendly {x}}.",
                   call = rlang::caller_env())
  }

  head_data <- x$labels$title
  # move tag to subtitle
  subhead_data <- c(x$labels$subtitle,x$labels$tag)
  foot_data <- x$labels$caption

  # set to null in ggplot object
  x$labels[c("title","subtitle", "caption", "tag")] <- NULL

  list(display = x,
       head_data = head_data,
       subhead_data = subhead_data,
       foot_data = foot_data)

}


#' Replace empty markdown labels in gt_tbl or gt_group with empty string
#' @param x a gt_tbl or gt_group
#' @keywords internal
#' @noRd
replace_empty_md <- function(x) {
  #TODO: remove this and set gt dep when this is released: https://github.com/rstudio/gt/pull/2120/changes

  if (inherits(x, "gt_tbl")) {
    # boxhead
    gt_tbl_labs <- x$`_boxhead`

    gt_tbl_labs <- gt_tbl_labs |>
      dplyr::mutate(
        column_label = lapply(.data$column_label, \(x) {
          if (inherits(x, "from_markdown")) {
            trimmed_lab <- unclass(trimws(x))
            if (identical(trimmed_lab, "")) {
              x <- ""
            }
          }
          x
        })
      )

    x$`_boxhead` <- gt_tbl_labs

     #stub
    gt_stub_labs <- x$`_stubhead`

    gt_stub_labs <- lapply(gt_stub_labs, \(x) {
      if (inherits(x, "from_markdown")) {
        trimmed_lab <- unclass(trimws(x))
        if (identical(trimmed_lab, "")) {
          x <- ""
        }
      }
      x
    })

    x$`_stubhead` <- gt_stub_labs

    # data - replace empty with invisible whitespace
    x$`_data`[x$`_data` == ""] <- "\u200B"
  }

  x
}