R/format_confrontation_report.R

In ReDaMoR: Relational Data Modeler

###############################################################################@
#' Format confrontation report for printing in console
#'
#' @param cr the confrontation report from [confront_data]
#' @param title a character with a single value corresponding to the report
#' title (e.g. database/model name)
#'
#' @example inst/examples/ex_confront.R
#'
#' @export
#'
format_confrontation_report <- function(
  cr,
  title = "Model"
) {
  ## Helpers ----
  successTag <- function(s) {
    if (s) {
      crayon::bgGreen(crayon::white('SUCCESS'))
    } else {
      crayon::bgRed(crayon::white('FAILURE'))
    }
  }
  messageTag <- function(m) {
    crayon::bgMagenta(crayon::white(m))
  }

  toRet <- c()

  ## Title ----
  toRet <- c(toRet, crayon::bold(crayon::underline(title)))

  ## Global success ----
  toRet <- c(toRet, successTag(cr$success))

  ## Global config ----
  toRet <- c(
    toRet,
    '',
    crayon::bold('Check configuration'),
    sprintf('   - Optional checks: %s', paste(cr$checks, collapse = ", ")),
    sprintf('   - Maximum number of records: %s', cr$n_max),
    ''
  )

  ## Missing tables ----
  if (length(cr$missingTables) > 0) {
    toRet <- c(
      toRet,
      crayon::bold('Missing tables'),
      'The following tables are missing:',
      paste("   -", cr$missingTables),
      ''
    )
  }

  ## Supplementary tables ----
  if (length(cr$suppTables) > 0) {
    toRet <- c(
      toRet,
      crayon::bold('Not supported tables'),
      'The following tables are not supported by the model:',
      '',
      paste("   -", cr$suppTables),
      ''
    )
  }

  ## Table information ----
  ttoRet <- unlist(lapply(
    names(cr$constraints),
    function(tn) {
      tcr <- cr$constraints[[tn]]
      toRet <- c()

      ### Missing fields ----
      if (length(tcr$missingFields) > 0) {
        toRet <- c(
          toRet,
          crayon::underline('Missing fields'),
          'The following fields are missing:',
          paste("   -", tcr$missingFields),
          ''
        )
      }

      ### Supplementary fields ----
      if (length(tcr$suppFields) > 0) {
        toRet <- c(
          toRet,
          crayon::underline('Not supported fields'),
          'The following fields are not supported by the model:',
          paste("   -", tcr$suppFields),
          ''
        )
      }

      ### Field information ----
      ftoRet <- unlist(lapply(
        names(tcr$fields),
        function(fn) {
          s <- tcr$fields[[fn]]$success
          m <- tcr$fields[[fn]]$message
          if (!s || (!is.null(m) && !is.na(m) && m != "")) {
            return(paste0(
              '   - ',
              fn,
              ': ',
              successTag(s),
              ' ',
              messageTag(m)
            ))
          } else {
            return(NULL)
          }
        }
      ))
      if (length(ftoRet) > 0) {
        toRet <- c(
          toRet,
          crayon::underline('Field issues or warnings'),
          ftoRet,
          ''
        )
      }

      ### Index information ----
      if (length(tcr$indexes) > 0) {
        itoRet <- unlist(lapply(
          1:length(tcr$indexes),
          function(i) {
            idx <- paste(cr$model[[tn]]$indexes[[i]]$fields, collapse = "+")
            if (cr$model[[tn]]$indexes[[i]]$unique) {
              idx <- paste(idx, '(unique)')
            }
            s <- tcr$indexes[[i]]$success
            m <- tcr$indexes[[i]]$message
            if (!s || (!is.null(m) && !is.na(m) && m != "")) {
              return(paste0(
                '   - ',
                idx,
                ': ',
                successTag(s),
                ' ',
                messageTag(m)
              ))
            } else {
              return(NULL)
            }
          }
        ))
        if (length(itoRet) > 0) {
          toRet <- c(
            toRet,
            crayon::underline('Index issues or warnings'),
            itoRet,
            ''
          )
        }
      }

      ### Foreign key information ----
      if (length(tcr$foreignKey) > 0) {
        fktoRet <- unlist(lapply(
          1:length(tcr$foreignKey),
          function(i) {
            fk <- paste(
              cr$model[[tn]]$foreignKeys[[i]]$key$from,
              cr$model[[tn]]$foreignKeys[[i]]$key$to,
              sep = "->"
            ) |>
              paste(collapse = " + ")
            fk <- paste0(
              cr$model[[tn]]$foreignKeys[[i]]$refTable,
              ' [',
              fk,
              ']'
            )
            s <- tcr$foreignKey[[i]]$success
            m <- tcr$foreignKey[[i]]$message
            if (!s || (!is.null(m) && !is.na(m) && m != "")) {
              return(paste0(
                '   - ',
                fk,
                ': ',
                successTag(s),
                ' ',
                messageTag(m)
              ))
            } else {
              return(NULL)
            }
          }
        ))
        if (length(fktoRet) > 0) {
          toRet <- c(
            toRet,
            crayon::underline('Foreign keys issues or warnings'),
            fktoRet,
            ''
          )
        }
      }

      ### Results if anything to show ----
      if (length(toRet) > 0 || !tcr$success) {
        toRet <- c(
          crayon::bold(tn),
          successTag(tcr$success),
          toRet,
          ''
        )
      }
    }
  ))

  if (length(ttoRet) > 0) {
    toRet <- c(
      toRet,
      ttoRet
    )
  }

  ## Concatenate the result ----
  return(paste(toRet, collapse = "\n"))
}

###############################################################################@
#' Format confrontation report in markdown format
#'
#' @param cr the confrontation report from [confront_data]
#' @param title a character with a single value corresponding to the report
#' @param level rmarkdown level in document hierarchy (default:0 ==> highest).
#' It should be an integer between 0 and 4.
#' @param numbered a logical. If TRUE (default) the sections are part of
#' document numbering.
#' @param bgSuccess background color for SUCCESS
#' @param txSuccess text color for SUCCESS
#' @param bgFailure background color for FAILURE
#' @param txFailure text color for FAILURE
#' @param bgMessage background color for a warning message
#' @param txMessage text color for a warning message
#'
#' @example inst/examples/ex_confront.R
#'
#' @export
#'
format_confrontation_report_md <- function(
  cr,
  title = "Model",
  level = 0,
  numbered = TRUE,
  bgSuccess = "green",
  txSuccess = "black",
  bgFailure = "red",
  txFailure = "white",
  bgMessage = "#FFBB33",
  txMessage = "white"
) {
  level <- round(level, digits = 0)
  stopifnot(level >= 0, level <= 4)

  ## Helpers ----
  successTag <- function(s) {
    sprintf(
      paste0(
        '<span ',
        'style="background-color:%s; color:%s; padding:2px;"',
        '>%s</span>'
      ),
      ifelse(s, bgSuccess, bgFailure),
      ifelse(s, txSuccess, txFailure),
      ifelse(s, 'SUCCESS', 'FAILURE')
    )
  }
  messageTag <- function(m) {
    sprintf(
      '<span style="background-color:%s; color:%s; padding:2px;">%s</span>',
      bgMessage,
      txMessage,
      m
    )
  }

  toRet <- c()

  ## Title ----
  toRet <- c(toRet, '', sprintf('# %s', title[1]), '')

  ## Global success ----
  toRet <- c(toRet, successTag(cr$success))

  ## Global config ----
  toRet <- c(
    toRet,
    '',
    '## Check configuration',
    '',
    sprintf('- **Optional checks**: %s', paste(cr$checks, collapse = ", ")),
    sprintf('- **Maximum number of records**: %s', cr$n_max),
    ''
  )

  ## Missing tables ----
  if (length(cr$missingTables) > 0) {
    toRet <- c(
      toRet,
      '',
      '## Missing tables',
      '',
      'The following tables are missing:',
      '',
      paste("-", cr$missingTables),
      ''
    )
  }

  ## Supplementary tables ----
  if (length(cr$suppTables) > 0) {
    toRet <- c(
      toRet,
      '',
      '## Not supported tables',
      '',
      'The following tables are not supported by the model:',
      '',
      paste("-", cr$suppTables),
      ''
    )
  }

  ## Table information ----
  ttoRet <- unlist(lapply(
    names(cr$constraints),
    function(tn) {
      tcr <- cr$constraints[[tn]]
      toRet <- c()

      ### Missing fields ----
      if (length(tcr$missingFields) > 0) {
        toRet <- c(
          toRet,
          '',
          '### Missing fields',
          '',
          'The following fields are missing:',
          '',
          paste(paste("-", tcr$missingFields)),
          ''
        )
      }

      ### Supplementary fields ----
      if (length(tcr$suppFields) > 0) {
        toRet <- c(
          toRet,
          '',
          '### Not supported fields',
          '',
          'The following fields are not supported by the model:',
          '',
          paste(paste("-", tcr$suppFields)),
          ''
        )
      }

      ### Field information ----
      ftoRet <- unlist(lapply(
        names(tcr$fields),
        function(fn) {
          s <- tcr$fields[[fn]]$success
          m <- tcr$fields[[fn]]$message
          if (!s || (!is.null(m) && !is.na(m) && m != "")) {
            return(paste0(
              '- ',
              fn,
              ': ',
              successTag(s),
              ' ',
              messageTag(m)
            ))
          } else {
            return(NULL)
          }
        }
      ))
      if (length(ftoRet) > 0) {
        toRet <- c(
          toRet,
          '',
          '### Field issues or warnings',
          '',
          ftoRet,
          ''
        )
      }

      ### Index information ----
      if (length(tcr$indexes) > 0) {
        itoRet <- unlist(lapply(
          1:length(tcr$indexes),
          function(i) {
            idx <- paste(cr$model[[tn]]$indexes[[i]]$fields, collapse = "+")
            if (cr$model[[tn]]$indexes[[i]]$unique) {
              idx <- paste(idx, '(unique)')
            }
            s <- tcr$indexes[[i]]$success
            m <- tcr$indexes[[i]]$message
            if (!s || (!is.null(m) && !is.na(m) && m != "")) {
              return(paste0(
                '- ',
                idx,
                ': ',
                successTag(s),
                ' ',
                messageTag(m)
              ))
            } else {
              return(NULL)
            }
          }
        ))
        if (length(itoRet) > 0) {
          toRet <- c(
            toRet,
            '',
            '### Index issues or warnings',
            '',
            itoRet,
            ''
          )
        }
      }

      ### Foreign key information ----
      if (length(tcr$foreignKey) > 0) {
        fktoRet <- unlist(lapply(
          1:length(tcr$foreignKey),
          function(i) {
            fk <- paste(
              cr$model[[tn]]$foreignKeys[[i]]$key$from,
              cr$model[[tn]]$foreignKeys[[i]]$key$to,
              sep = "->"
            ) |>
              paste(collapse = " + ")
            fk <- paste0(
              cr$model[[tn]]$foreignKeys[[i]]$refTable,
              ' [',
              fk,
              ']'
            )
            s <- tcr$foreignKey[[i]]$success
            m <- tcr$foreignKey[[i]]$message
            if (!s || (!is.null(m) && !is.na(m) && m != "")) {
              return(paste0(
                '- ',
                fk,
                ': ',
                successTag(s),
                ' ',
                messageTag(m)
              ))
            } else {
              return(NULL)
            }
          }
        ))
        if (length(fktoRet) > 0) {
          toRet <- c(
            toRet,
            '',
            '### Foreign keys issues or warnings',
            '',
            fktoRet,
            ''
          )
        }
      }

      ### Results if anything to show ----
      if (length(toRet) > 0 || !tcr$success) {
        toRet <- c(
          '',
          sprintf('## %s', tn),
          '',
          successTag(tcr$success),
          '',
          toRet,
          ''
        )
      }
    }
  ))

  if (length(ttoRet) > 0) {
    toRet <- c(
      toRet,
      ttoRet
    )
  }

  ## Set document level ----
  toRet <- sub(
    "^[#]",
    paste0("#", paste(rep("#", level), collapse = "")),
    toRet
  )
  ## Unnumber if requested ----
  if (!numbered) {
    h <- grep("^[#]", toRet)
    toRet[h] <- paste(toRet[h], "{.unlisted .unnumbered}")
  }

  ## Concatenate the result ----
  toRet <- paste(toRet, collapse = "\n")
  return(toRet)
}

###############################################################################@
#' View confrontation report in rstudio viewer
#'
#' @param cr the confrontation report from [confront_data]
#' @param ... additional params for
#' the [format_confrontation_report_md()] function
#'
#' @export
#'
view_confrontation_report <- function(cr, ...) {
  tf <- tempfile(fileext = ".html")
  on.exit(rm(tf))
  md <- format_confrontation_report_md(cr, ...)
  md <- markdown::renderMarkdown(text = md)
  writeLines(md, tf)
  rstudioapi::viewer(tf)
}