export_helpers.R

# CONSTANTS FOR PDF DESIGN ----
PDF_EXP <- pack_of_constants( # nolint
  LABEL_WIDTH = 6, # maximal number of rows that can be filled by the labels
  COL_TRANSITION = 2, # number of characters corresponding to the transition of one column to the next
  N_ROWS = 32, # allowed number of rows per page
  N_COL_CHARS = 115 # allowed number of characters within one row per page
)


#' Internal helper function that specifies the content of the download modal dialogue.
#'
#' @param ns A function that expects an ID and returns the namespaced ID, usually generated by `shiny::NS()`.
#' @param file_name `[character(1)]` A string containing the initial file name.
#' @param cond `[character(1)]` A string containing a JavaScript expression that will be evaluated
#' to determine whether the conditionalPanel should be displayed.
#' @param colnames `[character(0+)]` A character vector containing the reference column choices.
#' @param activate_checkbox `[logical(1)]` A boolean indicating whether the checkbox should be activated or not.
#' Default is FALSE.
#'
#' @return A shiny tagList.
#'
#' @keywords internal
export_modal_content <- function(ns, file_name, cond, colnames, activate_checkbox = FALSE) {
  # Check validity of parameters
  checkmate::assert(
    checkmate::check_function(ns, args = c("id"), nargs = 1),
    checkmate::check_string(file_name),
    checkmate::check_string(cond),
    checkmate::check_character(colnames, null.ok = TRUE),
    checkmate::check_logical(activate_checkbox),
    combine = "and"
  )

  return(
    shiny::tagList(
      shiny::radioButtons(
        ns(EXP$DATASEL_ID),
        EXP$DATASEL_LABEL,
        choices = c("Currently displayed listing" = "single", "All listings" = "all")
      ),
      shiny::textInput(ns(EXP$FILENAME_ID),
        EXP$FILENAME_LABEL,
        value = file_name
      ),
      shiny::radioButtons(
        ns(EXP$FILETYPE_ID),
        EXP$FILETYPE_LABEL,
        choices = c("Excel" = ".xlsx", "PDF" = ".pdf")
      ),
      shiny::conditionalPanel(
        cond,
        shiny::tagList(
          shiny::selectInput(
            ns(EXP$REFCOL_ID),
            label = shiny::tags$embed(
              shiny::div(
                EXP$REFCOL_LABEL,
                shinyWidgets::dropdownButton(
                  inputId = ns(EXP$REFCOL_INFO_ID),
                  shiny::tags$h6(shiny::tags$i(EXP$REFCOL_INFO_LABEL)),
                  size = "xs",
                  icon = shiny::icon("question-circle"),
                  inline = TRUE,
                  circle = TRUE,
                  label = "Show more information",
                  tooltip = TRUE
                )
              )
            ),
            choices = colnames,
            multiple = TRUE
          ),
          shiny::textInput(
            ns(EXP$SNAPSHOT_ID),
            label = shiny::tags$embed(
              shiny::div(
                EXP$SNAPSHOT_LABEL,
                shinyWidgets::dropdownButton(
                  inputId = ns(EXP$SNAPSHOT_INFO_ID),
                  shiny::tags$h6(shiny::tags$i(EXP$SNAPSHOT_INFO_LABEL)),
                  size = "xs",
                  icon = shiny::icon("question-circle"),
                  inline = TRUE,
                  circle = TRUE,
                  label = "Show more information",
                  tooltip = TRUE
                )
              )
            )
          )
        ),
        ns = ns
      ),
      if (activate_checkbox) {
        shiny::checkboxInput(
          inputId = ns(EXP$DATAPROTECT_ID),
          label = shiny::uiOutput(ns("label_id"), inline = TRUE),
          width = "100%"
        )
      }
    )
  )
}


#' Internal helper function to cut strings that exceed a specific length
#'
#' Shortens strings that are too long and denotes cutting by pasting "..." at the end of the string.
#'
#' @param vec `[character(0+)]` A character vector containing the strings to be cut if exceeding a maximal length.
#' @param len_max `[integer(1)]` An integer specifying the maximal length, must be equal to or greater than 3.
#'
#' @return A character vector containing the shortened strings in case they exceeded the maximal length.
#'
#' @keywords internal
shorten_entries <- function(vec, len_max) {
  # Check validity of parameters
  checkmate::assert(
    checkmate::check_character(vec, null.ok = TRUE),
    checkmate::check_integer(len_max, lower = 3, len = 1, null.ok = FALSE),
    combine = "and"
  )

  # Identify and cut strings that are too long
  too_long <- which(nchar(vec, keepNA = FALSE) > len_max)
  vec[too_long] <- paste0(substr(vec[too_long], 1, (len_max - 3)), "...")

  return(vec)
}


#' Internal helper function to prepare a data frame and determine the width of its columns for pdf export
#'
#' Shortens and splits the column label if necessary, so that it fits into `label_width` rows of its column.
#'
#' @param label `[character(1)]` A string representing the label.
#' @param min_width `[integer(1)]` An integer specifying the minimal width of the column (not less than 1).
#' @param max_width `[integer(1)]` An integer specifying the maximal width of the column
#' (greater than 3 and also not less than min_width `[integer(1)]`).
#' @param label_width `[integer(1)]` An integer specifying the maximal number of rows which is allocated for the label
#' (not less than 1).
#'
#' @return A list containing the `label_vec` which includes the splitted label and the actual width `col_width`.
#'
#' @keywords internal
split_label <- function(label, min_width, max_width, label_width) {
  # Check validity of parameters
  checkmate::assert(
    checkmate::check_string(label, null.ok = FALSE),
    checkmate::check_integer(min_width, lower = 1, len = 1, null.ok = FALSE),
    checkmate::check_integer(max_width, lower = max(3, min_width), len = 1, null.ok = FALSE),
    checkmate::check_integer(label_width, lower = 1, len = 1, null.ok = FALSE),
    combine = "and"
  )

  # Stop here if no label splitting needed
  if (nchar(label) <= min_width) {
    return(list(label_vec = label, col_width = min_width))
  }

  # Shorten labels that are too long (first shorten single words, then whole labels)
  label <- paste(shorten_entries(unlist(strsplit(label, " ")), len_max = as.integer(max_width)), collapse = " ")
  label <- shorten_entries(label, len_max = as.integer(max_width * label_width))
  # execute the first shorten entries call again in case the last word became too long
  label <- paste(shorten_entries(unlist(strsplit(label, " ")), len_max = as.integer(max_width)), collapse = " ")

  # Get word lengths
  label <- unlist(strsplit(label, " "))
  label_vec_ind <- c(0, 0)
  label_vec <- c()
  word_len_vec <- nchar(label) + 1 # + 1 for the blank between the words
  col_width <- min(max(
    min_width * ceiling(sum(as.numeric(word_len_vec <= min_width)) / label_width),
    ceiling(sum(word_len_vec) / label_width)
  ), max_width)

  while (length(word_len_vec) > 0 && length(label_vec) < label_width) {
    col_width <- max(col_width, word_len_vec[1])
    word_cumsum <- cumsum(word_len_vec)
    label_vec_ind <- c(label_vec_ind[2] + 1, label_vec_ind[2] + sum(as.numeric(word_cumsum <= col_width)))
    label_vec <- c(label_vec, paste(label[label_vec_ind[1]:label_vec_ind[2]], collapse = " "))
    word_len_vec <- word_len_vec[word_cumsum > col_width]
  }

  col_width <- max(min_width, col_width - 1) # to remove last blank

  # Mark that label was too long by appending "..."
  if (length(word_len_vec) > 0) {
    label_vec[length(label_vec)] <- paste0(substr(label_vec[length(label_vec)], 1, (col_width - 3)), "...")
  }

  return(list(label_vec = label_vec, col_width = as.integer(col_width)))
}


#' Internal helper function to prepare a data frame and determine the width of its columns for pdf export
#'
#' Shortens and splits the column labels if necessary, adapts the entries of the reference column vector for
#' easier handling, and determines the width of reference columns and data frame columns for upcoming pdf generation.
#' Widths are given in amount of characters.
#'
#' @param df `[data.frame]` A single data frame with named columns.
#' @param ref `[character(0+)]` A character vector whose entries specify a selection of columns of `df`.
#' The format of the entries follows: `name [label]`.
#'
#' @return The transformed reference column vector whose entries include solely the column names (`ref`),
#' the splitted labels as vectors stored within a list (`label_vecs`),
#' the maximal column widths for all data frame columns (`width_max`),
#' the maximal column widths for the reference columns (`ref_width`),
#' the maximal column widths for the non-reference columns of the dataframe (`width`),
#' the table width exclusively row names (`table_width`),
#' and a logical indicating whether the reference columns specification is valid (`check_ref_cols`).
#'
#' @keywords internal
calculate_col_width <- function(df, ref) {
  # Check validity of parameters
  checkmate::assert(
    checkmate::check_data_frame(df, min.rows = 1, min.cols = 1, col.names = "unique", null.ok = FALSE),
    checkmate::check_character(ref, null.ok = TRUE),
    combine = "and"
  )

  # Check if reference columns are part of data frame
  labels_df <- get_labels(df)
  names_df <- names(df)
  checkmate::assert_subset(ref, paste0(names_df, " [", labels_df, "]"))

  # Get allowed table width (excl. column for row names)
  table_width <- PDF_EXP$N_COL_CHARS - nchar(nrow(df))

  # Determine for each column the maximal width
  width_col <- if (nrow(df) > 1) {
    apply(apply(df, 2, nchar, keepNA = FALSE), 2, max)
  } else {
    apply(df, 2, nchar, keepNA = FALSE)
  }
  width_col <- pmin(width_col, table_width) # since entries will be shortened to not exceed table_width later
  width_names <- nchar(names_df, keepNA = FALSE)
  split_res <- purrr::map2(labels_df, pmax(width_col, width_names), ~ {
    split_label(.x, as.integer(.y), as.integer(table_width), as.integer(PDF_EXP$LABEL_WIDTH))
  })
  label_vecs <- lapply(split_res, function(x) x[["label_vec"]])
  width_max <- unlist(lapply(split_res, function(x) x[["col_width"]]))
  names(width_max) <- names(df) # since names vanish if we have only one row

  # Width of reference column(s) and width of remaining columns
  ref_ind <- match(paste0(names_df, " [", labels_df, "]"), ref)
  ref <- names_df[!is.na(ref_ind)]
  ref <- ref[ref_ind[!is.na(ref_ind)]] # to preserve the order of reference columns
  ref_width <- ifelse(length(ref) > 0, sum(width_max[ref]) + PDF_EXP$COL_TRANSITION * (length(ref) - 1), 0)
  width <- width_max[!(names(width_max) %in% ref)]

  # Check if a warning is necessary regarding the current ref col selection
  if (length(width) > 0) {
    check_ref_cols <- (max(width) <= (table_width - ref_width))
    check_ref_cols <- !check_ref_cols || length(width) == 0
  } else {
    check_ref_cols <- TRUE
  }

  # Return all necessary interim results
  return(list(
    ref = ref, label_vecs = label_vecs,
    width_max = width_max, ref_width = ref_width, width = width, table_width = table_width,
    check_ref_cols = check_ref_cols
  ))
}


#' Internal helper function to divide a data frame into smaller data frames that fit on one PDF page each
#'
#' Needed as preprocessing step before PDF creation by means of RMarkdown can take place.
#'
#' @param df `[data.frame]` A single data frame with named columns.
#' @param ref `[character(0+)]` A character vector whose entries specify a selection of columns of `df`.
#' The format of the entries follows: `name [label]`.
#'
#' @return Named list containing a list of data frames (`list_of_df`) whose entries fit on one PDF page each.
#'
#' @keywords internal
pdf_preprocessing <- function(df, ref) {
  # Check validity of parameters
  checkmate::assert(
    checkmate::check_data_frame(df, null.ok = FALSE),
    checkmate::check_character(ref, null.ok = TRUE),
    combine = "and"
  )

  # Check if reference columns are part of data frame
  labels_df <- get_labels(df)
  colnames_df <- names(df)
  rownames_df <- seq_len(nrow(df)) # rownames get lost (which is wanted because we download a listing + to save space)
  checkmate::assert_subset(ref, paste0(colnames_df, " [", labels_df, "]"))

  # Call calculate_col_width function which was outsourced to avoid code doubling
  res_col_width <- calculate_col_width(df, ref)
  ref <- res_col_width$ref
  label_vecs <- res_col_width$label_vecs
  ref_width <- res_col_width$ref_width
  width <- res_col_width$width
  table_width <- res_col_width$table_width

  # Shorten entries that are too long
  if (nrow(df) > 1) {
    df <- apply(
      apply(df, 2, as.character),
      2, shorten_entries,
      len_max = as.integer(table_width)
    )
  } else {
    df <- t(data.frame(shorten_entries(
      apply(df, 2, as.character),
      len_max = as.integer(table_width)
    )))
    rownames(df) <- "1"
  }

  # Remove reference column(s) from dataframe, labels, and names
  df_ref <- if (length(ref) > 0) {
    as.matrix(df[, ref])
  } else {
    NULL
  }
  labels_ref <- label_vecs[ref]
  if (nrow(df) > 1) {
    df <- as.matrix(df[, !(colnames_df %in% ref)])
  } else {
    df <- t(as.matrix(df[, !(colnames_df %in% ref)]))
    rownames(df) <- "1"
  }
  labels_df <- label_vecs[!(names(labels_df) %in% ref)]
  colnames_df <- colnames_df[!(colnames_df %in% ref)]

  # Given: table dimensions per PDF page
  n_cols <- table_width - ref_width - (ifelse(length(ref) > 0, 1, 0) * PDF_EXP$COL_TRANSITION)
  n_rows_pages <- ceiling(nrow(df) / PDF_EXP$N_ROWS)

  # Determine with which columns the next page should start
  start_new_page <- 1
  width_cumsum <- width
  if (length(width_cumsum) > 2) {
    width_cumsum[2:(length(width_cumsum) - 1)] <- width_cumsum[2:(length(width_cumsum) - 1)] + PDF_EXP$COL_TRANSITION
  }
  width_cumsum <- cumsum(width_cumsum)
  while (width_cumsum[length(width_cumsum)] > n_cols && length(width_cumsum) > 1) {
    start_new_page <- c(
      start_new_page, which(width_cumsum > n_cols)[1] - 1 + start_new_page[length(start_new_page)]
    )
    width_cumsum <- cumsum(width[start_new_page[length(start_new_page)]:length(width)] + PDF_EXP$COL_TRANSITION)
  }

  # Create index list which contains for every page the start and end row and the start and end column
  index_list <- lapply(1:n_rows_pages, function(i) {
    return(lapply(seq_along(start_new_page), function(j) {
      ind_i <- ifelse(i < n_rows_pages, i * PDF_EXP$N_ROWS, nrow(df))
      ind_j <- ifelse(j < length(start_new_page), start_new_page[j + 1] - 1, ncol(df))
      return(c((i - 1) * PDF_EXP$N_ROWS + 1, ind_i, start_new_page[j], ind_j))
    }))
  })
  index_list <- purrr::flatten(index_list)

  # Create list of small data frames (one per page) according to index_list and add reference columns
  list_of_df <- lapply(index_list, function(index) {
    sub_df <- if (nrow(df) > 1) {
      cbind(df_ref[index[1]:index[2], ], df[index[1]:index[2], index[3]:index[4]])
    } else {
      c(df_ref[index[1]:index[2], ], df[index[1]:index[2], index[3]:index[4]])
    }

    sub_df_labels <- matrix(unlist(c(
      lapply(labels_ref, function(x) {
        c(x, rep(NA, PDF_EXP$LABEL_WIDTH - length(x)))
      }),
      lapply(labels_df[index[3]:index[4]], function(x) {
        c(x, rep(NA, PDF_EXP$LABEL_WIDTH - length(x)))
      })
    )), nrow = PDF_EXP$LABEL_WIDTH, ncol = ifelse(is.null(ncol(sub_df)), length(sub_df), ncol(sub_df)))

    sub_df <- data.frame(rbind(sub_df_labels, sub_df))
    rownames(sub_df) <- c(
      purrr::imap(rep("", PDF_EXP$LABEL_WIDTH), ~ paste(rep(.x, .y), collapse = " ")),
      rownames_df[index[1]:index[2]]
    )
    colnames(sub_df) <- c(ref, colnames_df[index[3]:index[4]])

    # Replace all NAs
    sub_df[is.na(sub_df)] <- ""

    return(sub_df)
  })


  # Return list of data frames that fit on one page as well as the width of all columns for pdf design
  return(list_of_df)
}


#' Internal helper function for preparing the dataset(s) to download.
#'
#' @param  data_selection `[character(1)]` Either \code{"single"} or \code{"all"} depending on whether the
#' currently displayed dataset (\code{current_data}) or all datasets (\code{dataset_list}) should be downloaded.
#' @param current_data `[data.frame]` A single data frame with named columns.
#' @param data_selection_name `[character(1)]` A string specifying the name of \code{current_data}.
#' @param dataset_list `[list(data.frame)]` A list of named datasets.
#'
#' @return Named list containing the data frames which are now ready for download.
#'
#' @keywords internal
prep_export_data <- function(data_selection, current_data, data_selection_name, dataset_list, footers) {
  # check validity of parameters
  checkmate::assert(
    checkmate::check_string(data_selection),
    checkmate::check_subset(data_selection, choices = c("single", "all")),
    checkmate::check_data_frame(current_data, null.ok = FALSE),
    checkmate::check_string(data_selection_name),
    checkmate::check_list(dataset_list, types = "data.frame"),
    combine = "and"
  )

  if (data_selection == "single") {
    data_to_download <- list(current_data)
    names(data_to_download) <- data_selection_name
  } else {
    data_to_download <- dataset_list
  }

  shortened_names <- shorten_entries(
    paste0(names(data_to_download), " (", get_labels(data_to_download), ")"),
    as.integer(31) # name has to be shortened to 31 characters due to Excel's sheet name limit
  )

  data_to_download <- local({
    res <- list()
    for (i_dataset in seq_along(data_to_download)){
      df <- data_to_download[[i_dataset]]
      
      # convert types to character to avoid representation issues in Excel
      labels <- get_labels(df)
      data <- data.frame(sapply(df, as.character))
      data <- set_labels(data, labels)
     
      # attach footer, if available
      dataset_name <- names(data_to_download)[[i_dataset]]
      attr(data, "footer") <- footers[[dataset_name]]
      
      res[[length(res) + 1]] <- data
    }
    return(res)
  })
    
  names(data_to_download) <- shortened_names

  return(data_to_download)
}


#' Internal helper function which performs the download as .xlsx file.
#'
#' Will export all datasets listed within \code{data_to_download} into a separate
#' Excel worksheet. Column names of the datasets will be extended by their labels.
#'
#' @param data_to_download `[list(data.frame)]` A list of data frames to be downloaded.
#' @param file `[character(1)]` A string specifying the filename with ending ".xlsx".
#'
#' @keywords internal
excel_export <- function(data_to_download, file, intended_use_label) {
  # Check validity of parameters
  checkmate::assert(
    checkmate::check_list(data_to_download, types = "data.frame", null.ok = FALSE),
    checkmate::check_path_for_output(file, overwrite = TRUE, extension = "xlsx"),
    checkmate::check_string(intended_use_label, null.ok = TRUE),
    combine = "and"
  )

  # Add column labels and footers
  data_to_download <- lapply(data_to_download, function(x) {
    names(x) <- paste0(names(x), " [", get_labels(x), "]")
    footer <- attr(x, "footer")
    if (!is.null(footer)) {
      first_new_row <- nrow(x) + 1
      last_new_row <- nrow(x) + length(footer)
      x[first_new_row:last_new_row, ] <- NA
      x[first_new_row:last_new_row, 1] <- footer
    }
    return(x)
  })

  # Add first sheet as title page
  title_page <- data.frame(c(EXP$EXP_TITLE, intended_use_label))
  colnames(title_page) <- ""
  data_to_download <- c("info" = title_page, data_to_download)

  # Export dataset as Excel
  openxlsx::write.xlsx(data_to_download, file)
}


#' Internal helper function which performs the download as .pdf file.
#'
#' Will export the dataset listed within \code{data_to_download} into a PDF file.
#'
#' @param data_to_download `[list(data.frame)]` A named list containing one data frame to be downloaded.
#' #' @param ref `[character(0+)]` A character vector whose entries specify a selection of columns of the
#' dataset to download. The format of the entries follows: `name [label]`.
#' @param file `[character(1)]` A string specifying the filename with ending ".pdf".
#' @param metadata `[character(3)]` A character vector specifying the dataset's name, date, and an
#' additional footnote text.
#' @param active_session `[logical(1)]` Logical value that indicates if the helper function is used within a shiny
#' session. If yes, the parts for displaying a progress bar get activated. Defaults to `TRUE`.
#'
#' @return Number of PDF pages that are generated.
#'
#' @keywords internal
pdf_export <- function(data_to_download, ref_cols, file, metadata, active_session = TRUE, intended_use_label) {
  # Check validity of parameters
  checkmate::assert(
    checkmate::check_list(data_to_download, types = "data.frame", len = 1, null.ok = FALSE),
    checkmate::check_character(ref_cols, null.ok = TRUE),
    checkmate::check_path_for_output(file, overwrite = TRUE, extension = "pdf"),
    checkmate::check_character(metadata, len = 3),
    checkmate::check_logical(active_session, len = 1),
    combine = "and"
  )

  # PDF preprocessing
  res_preprocess <- pdf_preprocessing(data_to_download[[1]], ref_cols)

  # Copy Rmd file to a folder with writing permissions for deployment
  temp_report <- file.path(tempdir(), "create_pdf_export.Rmd")
  file.copy(
    system.file("rmd", "create_pdf_export.Rmd", package = "dv.listings", mustWork = TRUE),
    temp_report,
    overwrite = TRUE
  )

  # Render pdf via RMarkdown file
  out <- rmarkdown::render(
    temp_report,
    params = list(
      set_title = EXP$EXP_TITLE,
      set_subtitle = intended_use_label,
      dataset_name = gsub("_", "\\\\_", names(data_to_download)), # Rmd does not allow underscore
      trial_name = gsub("_", "\\\\_", metadata[1]), # Rmd does not allow underscore
      time_stamp = gsub("[^-/A-Za-z0-9!?.,:() ]", "?", metadata[2]), # replace characters that could cause problems
      snap_shot_name = gsub("[^-/A-Za-z0-9!?.,:() ]", "?", metadata[3]), # same here
      footer = attr(data_to_download[[1]], "footer"),
      df_list = res_preprocess,
      active_session = active_session
    ),
    envir = new.env(parent = globalenv()),
    output_format = "pdf_document"
  )
  # copy+remove instead of rename because we can't guarantee that the temp folder lives in the same filesystem as `file`
  file.copy(out, file)
  file.remove(out)

  # This is mainly needed for the progress bar
  return(length(res_preprocess))
}


#' Internal helper function for warnings in case of missing/wrong selections done by the user.
#'
#' Triggers a warning feedback if a particular condition is true and hides the
#' feedback if it is false by using \pkg{shinyFeedback}.
#'
#' @param cond `[logical(1)]` Logical value that indicates whether the warning should be triggered (if `TRUE`) or
#' not (if `FALSE`).
#' @param input_id `[character(1)]` ID string indicating at which input field the warning should appear.
#' @param text `[character(1)]` A string containing the warning message to be displayed.
#'
#' @keywords internal
warn_function <- function(cond, input_id, text) {
  # Check validity of parameters
  checkmate::assert(
    checkmate::check_logical(cond, len = 1),
    checkmate::check_string(input_id, min.chars = 1),
    checkmate::check_string(text),
    combine = "and"
  )

  if (cond) {
    shinyFeedback::showFeedback(
      inputId = input_id,
      text = text,
      color = EXP$WARN_COLOR
    )
  } else {
    shinyFeedback::hideFeedback(input_id)
  }
}