R/format_metrics_data.R

In glenn-m/promR: Prometheus API Client

#' @section Utility function for parsing metrics output:
#'   Formats metrics data from the current query
#' @param x A data frame generated by Prometheus query
#' @rdname utilities

format_metrics_instant_data <- function(x) {
  # Clean column names
  x <- rename_metrics_data_frame(x)
  within(data = x,
         expr = {
           port = as.integer(gsub(
             pattern = "(.*):(.*)",
             replacement = "\\2",
             x = instance
           ))

           instance = gsub(pattern = "(.*):(.*)",
                           replacement = "\\1",
                           x = instance)

           value = destring(value)
         })
}


#' @section Utility function for parsing range metrics output:
#'   Formats metrics data passed by range query.
#' @rdname utilities
format_metrics_range_data <- function(x) {
  checkmate::assert_data_frame(x = x,
                               min.rows = 1,
                               min.cols = 2)
  # Clean column names
  x <- rename_metrics_data_frame(x)
  x_metrics <- within(data = x$metric,
                      expr = {
                        port = as.integer(gsub(
                          pattern = "(.*):(.*)",
                          replacement = "\\2",
                          x = instance
                        ))

                        instance = gsub(pattern = "(.*):(.*)",
                                        replacement = "\\1",
                                        x = instance)
                      })

  dfs_to_bind <- lapply(
    X = x$values,
    FUN = function(value_pair) {
      setNames(object = as.data.frame(value_pair),
               nm = c("timestamp", "value")) -> df_ts_val
    }
  )

  i <- 1
  res <- Reduce(rbind,
                lapply(
                  X = dfs_to_bind,
                  FUN = function(dfs) {
                    x <- suppressWarnings(cbind(x_metrics[i,], dfs))
                    i <<- i + 1
                    x
                  }
                ))

  res <- within(data = res,
                expr = {
                  value = destring(value)
                })

  return(res)
}

#' @section Utility function for parsing metadata output:
#'   Formats data passed by metadata query.
#' @rdname utilities
format_metadata <- function(x) {
  checkmate::assert_data_frame(x = x,
                               min.rows = 1,
                               min.cols = 2)

  res <- rename_metadata_data_frame(x)

  return(res)
}

#' @section Utility function cleaning column names:
#'   As there is no clarity with respect to the returned columns the function:
#'   \itemize{
#'     \item Changes names of known columns like \code{target.instance, target.job}
#'     \item Removes special characters from all columns
#'   }
#' @rdname utilities
rename_metadata_data_frame <- function(x) {
  # For columns of known messy values provide replacements
  clean_names <- do.call(what = 'gsub',
                         args = list(
                           x = names(x),
                           pattern = c(".*instance.*"),
                           replacement = c("instance")
                         ))

  clean_names <- do.call(what = 'gsub',
                         args = list(
                           x = clean_names,
                           pattern = c(".*job.*"),
                           replacement = c("job")
                         ))
  # Set names on X
  x <- setNames(object = x, nm = clean_names)
  return(x)
}

#' @section Utility function cleaning column names:
#'   As there is no clarity with respect to the returned columns the function:
#'   \itemize{
#'     \item Changes names of known columns like \code{name}
#'     \item Removes special characters from all columns
#'   }
#' @rdname utilities
rename_metrics_data_frame <- function(x) {
  x_names <- names(x)
  if (is.null(x_names)) {
    return(x)
  }
  # For columns of known messy values provide replacements
  clean_names <- do.call(what = 'gsub',
                         args = list(
                           x = x_names,
                           pattern = c(".*name.*"),
                           replacement = c("name")
                         ))
  # Set names on X
  x <- setNames(object = x, nm = clean_names)
  return(x)
}

#' @section Utility function used to destring value column:
#'   The \code{value} columns should always contain numerical values, the
#'   function ensures that those are returned as of \code{numeric} type.
#' @rdname utilities
destring <- function(x) {
  withCallingHandlers(
    expr = {
      if (is.character(x)) {
        as.numeric(x)
      } else if (is.factor(x)) {
        as.numeric(levels(x))[x]
      } else if (is.numeric(x)) {
        x
      }
    },
    warning = function(w) {
      if (startsWith(conditionMessage(w), "NAs introduced by")) {
        invokeRestart("muffleWarning")
        cat("Not all received values were numeric:",
            conditionMessage(w))
      }
    }
  )
}