Nothing
#' Definition of the profile data format
#'
#' @description
#' The data format is stable between major releases.
#' In case of major updates, compatibility functions will be provided.
#'
#' The `validate_profile()` function checks a profile data object
#' for compatibility with the specification.
#' Versioning information embedded in the data is considered.
#'
#' @section Data model:
#' \figure{dm.png}
#' @name validate_profile
#' @param x Profile data, e.g., as returned by [read_pprof()] or [read_rprof()].
#' @export
#' @examples
#' rprof_file <- system.file("samples/rprof/1.out", package = "profile")
#' ds <- read_rprof(rprof_file)
#' validate_profile(ds)
#'
#' bad_ds <- ds
#' bad_ds$samples <- NULL
#' try(validate_profile(bad_ds))
validate_profile <- function(x) {
#' @details
#' The profile data is stored in an object of class `"profile_data"`,
#' which is a named list of [tibble]s.
stopifnot(is.list(x))
stopifnot(inherits(x, "profile_data"))
components <- undotted(names(x))
stopifnot(map_lgl(x[components], tibble::is_tibble))
#' This named list has the following components, subsequently referred to as
#' *tables*:
#' - `meta`
#' - `sample_types`
#' - `samples`
#' - `locations`
#' - `functions`
stopifnot(identical(
undotted(names(x)),
c("meta", "sample_types", "samples", "locations", "functions")
))
#' (Components with names starting with a dot are permitted
#' after the required components, but will be ignored.)
#'
#' The `meta` table has two character columns, `key` and `value`.
#' Additional columns with a leading dot in the name are allowed
#' after the required columns.
stopifnot(undotted(names(x$meta)) == c("key", "value"))
stopifnot(is.character(x$meta$key))
stopifnot(is.character(x$meta$value))
#' It is currently restricted to one row with key `"version"` and a value
#' that is accepted by [package_version()].
stopifnot(nrow(x$meta) == 1)
stopifnot(x$meta$key == "version")
package_version(x$meta$value)
#'
#' The `sample_types` table has two character columns, `type` and `unit`.
#' Additional columns with a leading dot in the name are allowed
#' after the required columns.
stopifnot(undotted(names(x$sample_types)) == c("type", "unit"))
stopifnot(is.character(x$sample_types$type))
stopifnot(is.character(x$sample_types$unit))
#' It is currently restricted to one row with values `"samples"` and `"count"`,
#' respectively.
stopifnot(nrow(x$sample_types) == 1)
stopifnot(x$sample_types$type == "samples")
stopifnot(x$sample_types$unit == "count")
#'
#' The `samples` table has two columns, `value` (integer) and `locations`
#' (list).
#' Additional columns with a leading dot in the name are allowed
#' after the required columns.
stopifnot(undotted(names(x$samples)) == c("value", "locations"))
stopifnot(is.integer(x$samples$value))
stopifnot(is.list(x$samples$locations))
#' The `value` column describes the number of consecutive samples for the
#' given location, and must be greater than zero.
stopifnot(x$samples$value > 0)
#' Each element of the `locations` column is a tibble with one integer column,
#' `location_id`.
stopifnot(map_lgl(x$samples$locations, tibble::is_tibble))
stopifnot(map_chr(x$samples$locations, map_chr, class) == "integer")
stopifnot(map_chr(x$samples$locations, names) == "location_id")
#' For each `location_id` value a corresponding observation in the `locations`
#' table must exist.
stopifnot(unlist(map(x$samples$locations, "[[", "location_id")) %in% x$locations$location_id)
#' The locations are listed in inner-first order, i.e., the first location
#' corresponds to the innermost entry of the stack trace.
#'
#' The `locations` table has three integer columns, `location_id`,
#' `function_id`, and `line`.
#' Additional columns with a leading dot in the name are allowed
#' after the required columns.
stopifnot(undotted(names(x$locations)) == c("location_id", "function_id", "line"))
stopifnot(is.integer(x$locations$location_id))
stopifnot(is.integer(x$locations$function_id))
stopifnot(is.integer(x$locations$line))
#' All `location_id` values are unique.
stopifnot(!anyDuplicated(x$locations$location_id))
#' For each `function_id` value a corresponding observation in the `functions`
#' table must exist. `NA` values are permitted.
stopifnot(is.na(x$locations$function_id) | x$locations$function_id %in% x$functions$function_id)
#' The `line` column describes the line in the source code this location
#' corresponds to, zero if unknown. All values must be nonnegative.
#' `NA` values are permitted.
stopifnot(is.na(x$locations$line) | x$locations$line >= 0)
#'
#' The `functions` table has five columns, `function_id` (integer),
#' `name`, `system_name` and `file_name` (character), and `start_line` (integer).
#' Additional columns with a leading dot in the name are allowed
#' after the required columns.
stopifnot(undotted(names(x$functions)) == c("function_id", "name", "system_name", "filename", "start_line"))
stopifnot(is.integer(x$functions$function_id))
stopifnot(is.character(x$functions$name))
stopifnot(is.character(x$functions$system_name))
stopifnot(is.character(x$functions$filename))
stopifnot(is.integer(x$functions$start_line))
#' All `function_id` values are unique.
stopifnot(!anyDuplicated(x$functions$function_id))
#' The `name`, `system_name` and `filename` columns describe function names
#' (demangled and mangled), and source file names for a function.
#' Both `name` and `system_name` must not contain empty strings.
stopifnot(x$functions$name != "")
stopifnot(x$functions$system_name != "")
#' The `start_line` column describes the start line of a function in its
#' source file, zero if unknown. All values must be nonnegative.
stopifnot(x$functions$start_line >= 0)
}
undotted <- function(x) {
x[seq_len(max(grep("^[^.]", x)))]
}
get_default_meta <- function() {
tibble::tibble(
key = "version",
value = "1.0"
)
}
new_profile_data <- function(x) {
structure(x, class = "profile_data")
}
#' @export
print.profile_data <- function(x, ...) {
cat(format(x, ...), sep = "\n")
invisible(x)
}
#' @export
format.profile_data <- function(x, ...) {
paste0("Profile data: ", nrow(x$samples), " samples")
}
#' dm_from_profile
#'
#' @description
#' The `dm_from_profile()` function converts a profile to a dm object.
#' The \pkg{dm} package must be installed.
#' See [dm::dm()] for more information.
#'
#' @rdname validate_profile
#' @export
#' @examples
#'
#' if (rlang::is_installed("dm")) {
#' dm <- dm_from_profile(ds)
#' print(dm)
#' dm::dm_draw(dm)
#' }
dm_from_profile <- function(x) {
stopifnot(inherits(x, "profile_data"))
stopifnot(rlang::is_installed("dm"))
samples <- x$samples
locations <- x$locations
functions <- x$functions
samples$sample_id <- seq_len(nrow(samples))
samples_locations <- tibble::tibble(
sample_id = rep(samples$sample_id, vapply(samples$locations, nrow, integer(1))),
location_id = tibble::as_tibble(do.call(rbind, samples$locations))
)
samples$locations <- NULL
#' @importFrom tibble %>%
dm::dm(samples, locations, functions, samples_locations) %>%
dm::dm_add_pk(functions, function_id) %>%
dm::dm_add_pk(locations, location_id) %>%
dm::dm_add_pk(samples, sample_id) %>%
dm::dm_add_fk(samples_locations, sample_id, samples) %>%
dm::dm_add_fk(samples_locations, location_id, locations) %>%
dm::dm_add_fk(locations, function_id, functions)
}
utils::globalVariables("function_id")
utils::globalVariables("location_id")
utils::globalVariables("sample_id")
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.