R/pkgndep.R

Defines functions .onAttach load_pkg dep plot.pkgndep unavailable_pkg loaded_ns print.pkgndep pkgndep

Documented in loaded_ns pkgndep plot.pkgndep print.pkgndep unavailable_pkg

# == title
# Number of Dependency Packages
#
# == param
# -pkg Package name or the path of the package.
# -verbose Whether print messages. 
#
# == details
# For each package listed in the "Depends", "Imports" and "Suggests" fields
# in the DESCRIPTION file, this function opens a new R session, loads the package
# and counts the number of namespaces that are loaded.
#
# == value
# A ``pkgndep`` object.
#
# == example
# \donttest{
# x = pkgndep("ComplexHeatmap")
# }
# # The `x` variable generated by `pkgndep()` is already saved in this package.
# x = readRDS(system.file("extdata", "x.rds", package = "pkgndep"))
# x
# plot(x)
# 
pkgndep = function(pkg, verbose = TRUE) {

	if(verbose) {
		cat(blue(qq("========== checking @{pkg} ==========\n")))
	}
	if(file.exists(pkg)) {
		x = read.dcf(paste0(pkg, "/DESCRIPTION"))
		x = as.data.frame(x)
	} else {
		x = packageDescription(pkg)
	}

	if(is.null(x$Depends)) {
		depends = character(0)
	} else {
		depends = x$Depends
		depends = gsub("\\s*\\(.*?\\)", "", depends)
		depends = strsplit(depends, ",\\s*")[[1]]
		depends = depends[depends != "R"]
	}

	if(is.null(x$Imports)) {
		imports = character(0)
	} else {
		imports = x$Imports
		imports = gsub("\\s*\\(.*?\\)", "", imports)
		imports = strsplit(imports, ",\\s*")[[1]]
	}

	if(is.null(x$Suggests)) {
		suggests = character(0)
	} else {
		suggests = x$Suggests
		suggests = gsub("\\s*\\(.*?\\)", "", suggests)
		suggests = strsplit(suggests, ",\\s*")[[1]]
	}

	dep_lt = lapply(depends, dep, verbose)
	names(dep_lt) = depends
	imp_lt = lapply(imports, dep, verbose)
	names(imp_lt) = imports
	sug_lt = lapply(suggests, dep, verbose)
	names(sug_lt) = suggests

	all_pkg = c(depends, imports, suggests)

	if(length(all_pkg) == 0) {
		obj = list(
			package = x$Package,
			version = x$Version,
			mat = matrix(nrow = 0, ncol = 0), 
			pkg_category = character(0),
			pkg_available = logical(0),
			n1 = 0,
			n2 = 0
		)

		class(obj) = "pkgndep"
		return(obj)
	}

	dep_lt2 = dep_lt[!sapply(dep_lt, is.null)]
	imp_lt2 = imp_lt[!sapply(imp_lt, is.null)]
	sug_lt2 = sug_lt[!sapply(sug_lt, is.null)]

	all_pkg_dep = unique(unlist(c(lapply(dep_lt2, function(x) x[, 1]), 
		                          lapply(imp_lt2, function(x) x[, 1]), 
		                          lapply(sug_lt2, function(x) x[, 1]))))

	m = matrix(NA, nrow = length(all_pkg), ncol = length(all_pkg_dep), dimnames = list(all_pkg, all_pkg_dep))
	tm = numeric(nrow(m))
	names(tm) = rownames(m)
	for(nm in names(dep_lt2)) {
		y = structure(dep_lt2[[nm]][, 2], names = dep_lt2[[nm]][, 1])
		m[nm, names(y)] = y
		tm[nm] = dep_lt2[[nm]][, 3][1]
	}
	for(nm in names(imp_lt2)) {
		y = structure(imp_lt2[[nm]][, 2], names = imp_lt2[[nm]][, 1])
		m[nm, names(y)] = y
		tm[nm] = imp_lt2[[nm]][, 3][1]
	}
	for(nm in names(sug_lt2)) {
		y = structure(sug_lt2[[nm]][, 2], names = sug_lt2[[nm]][, 1])
		m[nm, names(y)] = y
		tm[nm] = sug_lt2[[nm]][, 3][1]
	}

	pkg_category = c(rep("Depends", length(dep_lt)), rep("Imports", length(imports)), rep("Suggests", length(suggests)))
	pkg_available = !sapply(c(dep_lt, imp_lt, sug_lt), is.null)

	obj = list(
		package = x$Package,
		version = x$Version,
		mat = m, 
		pkg_category = pkg_category,
		pkg_available = pkg_available,
		loading_time = tm,
		n1 = sum(apply(m[pkg_category %in% c("Depends", "Imports"), , drop = FALSE], 2, function(x) any(!is.na(x)))),
		n2 = sum(apply(m, 2, function(x) any(!is.na(x))))
	)

	class(obj) = "pkgndep"
	return(obj)
}

# == title
# Print method
#
# == param
# -x The object from `pkgndep`.
# -... Other arguments.
#
# == value
# No value is returned.
#
# == example
# # See examples in `pkgndep()`.
#
print.pkgndep = function(x, ...) {
	qqcat("@{x$package} version @{x$version}\n")
	qqcat("@{x$n1} namespaces loaded if only load packages in Depends and Imports\n")
	qqcat("@{x$n2} namespaces loaded after loading all packages in Depends, Imports and Suggests\n")
}

# == title
# Loaded namespaces
#
# == param
# -x The object from `pkgndep`.
# -include_suggests Whether include the namespaces that are loaded if loading the packages from "Suggests" field.
#
# == value
# A vector of namespace names.
#
loaded_ns = function(x, include_suggests = TRUE) {
	if(include_suggests) {
		sort(colnames(x$mat))
	} else {
		l = apply(x$m[x$pkg_category %in% c("Depends", "Imports"), , drop = FALSE], 2, function(x) any(!is.na(x)))
		sort(colnames(x$mat)[l])
	}
}

# == title
# Unavailable packages
#
# == param
# -x The object from `pkgndep`.
#
# == details
# It lists the packages that are not installed in the "Suggests" field.
#
# == value
# A vector of package names.
#
unavailable_pkg = function(x) {
	sort(rownames(x$mat)[!x$pkg_available])
}

# == title
# Plot method
#
# == param
# -x The object from `pkgndep`.
# -pkg_fontsize Fontsize for the package names.
# -title_fontsize Fontsize for the titles.
# -legend_fontsize Fontsize for the legends.
# -fix_size Should the rows and columns in the heatmap have fixed size?
# -unit The unit of the returned figure width and height.
# -cex A factor multiplicated to all font sizes.
# -... Other arguments.
#
# == details
# If ``fix_size`` is set to ``TRUE``. The size of the whole plot can be obtained by:
#
#     size = plot(x, fix_size = TRUE)
#
# where ``size`` is a `grid::unit` object with the width and height of the whole heatmap.
# If you want to save the plot in to e.g. a PDF file that has the same size of the heatmap, you
# need to make the plot twice. First save the plot into a null device, just to obtain the size 
# of the plot:
#
#     pdf(NULL) # a null device
#     size = plot(x, fix_size = TRUE)
#     dev.off()
#     width = as.numeric(size[1])
#     height = as.numeric(size[2])
#     pdf(..., width = width, height = height)
#     plot(x)
#     dev.off()
#
# If there are no dependency packages stored in ``x``, ``NULL`` is returned.
# 
# == value
# A list of two units that correspond to the width and height of the plot.
#
# == example
# # See examples in `pkgndep()`.
#
plot.pkgndep = function(x, pkg_fontsize = 10*cex, title_fontsize = 12*cex, legend_fontsize = 8*cex, 
	fix_size = !dev.interactive(), unit = "in", cex = 1, ...) {

	m = x$mat
	row_split = x$pkg_category

	if(ncol(m) == 0) {
		return(invisible(NULL))
	}

	base_pkgs = c("base", "compiler", "datasets", "graphics", "grDevices", "grid", "methods",
		"parallel", "splines", "stats", "stats4", "tcltk", "tools", "utils")
	
	# a rude way to move all packages which are attached by imported packages before those by suggested packages
	column_order_by = apply(m, 2, function(x) sum(!is.na(x)))
	l = row_split %in% c("Depends", "Imports")
	l2 = apply(m[l, ,drop = FALSE], 2, function(x) sum(!is.na(x))) > 0
	column_order_by[l2] = column_order_by[l2] + 10000
	column_order = order(column_order_by, decreasing = TRUE)
	
	line_height = grobHeight(textGrob("A", gp = gpar(fontsize = pkg_fontsize)))*1.5

	ht = Heatmap(m, 
		name = x$package,
		row_split = row_split,
		column_split = ifelse(colnames(m) %in% base_pkgs, "Base packages", "Other packages"),
		heatmap_legend_param = list(nrow = 1, title = "", labels_gp = gpar(fontsize = legend_fontsize)), 
		rect_gp = gpar(col = "#DDDDDD"),
		show_row_dend = FALSE, 
		show_column_dend = FALSE,
		col = c("basePkgs" = "red", "loadedOnly" = "blue", "otherPkgs" = "darkgreen"),
		row_order = order(apply(m, 1, function(x) sum(!is.na(x)))),
		column_order = column_order,
		column_names_gp = gpar(fontsize = pkg_fontsize),
		row_names_gp = gpar(fontsize = pkg_fontsize),
		column_title_gp = gpar(fontsize = title_fontsize),
		row_title_gp = gpar(fontsize = title_fontsize),
		row_title_rot = 90,
		width = if(fix_size) ncol(m)*line_height else NULL,
		height = if(fix_size) nrow(m)*line_height else NULL
	)

	loading_time = x$loading_time
	lt_breaks = grid.pretty(c(0, max(loading_time, 0.1)))
	lt_labels = paste0(lt_breaks, "s")
	ht = ht + rowAnnotation(n_pkg = anno_barplot(apply(m, 1, function(x) sum(!is.na(x))), width = unit(2.5, "cm"),
								axis_param = list(gp = gpar(fontsize = 8*cex))),
			show_annotation_name = FALSE) +
		rowAnnotation("sec" = anno_barplot(loading_time, width = unit(2.5, "cm"),
			ylim = c(0, max(loading_time, 0.1)), axis_param = list(gp = gpar(fontsize = 8*cex), at = lt_breaks, labels = lt_labels)),
			show_annotation_name = FALSE) +
		rowAnnotation(pkg = anno_text(rownames(m), 
			gp = gpar(fontsize = pkg_fontsize, 
				col = ifelse(x$pkg_available, "black", "#AAAAAA"),
				fontface = ifelse(x$pkg_available, "plain", 'italic'))))
		
	ht = draw(ht, ht_gap = unit(c(3, 1, 1), "mm"),
		heatmap_legend_side = "bottom", 
		adjust_annotation_extension = FALSE,
		column_title = qq("In total @{ncol(m)} namespaces are loaded directly or indirectly when loading @{x$package} (@{x$version})"),
		column_title_gp = gpar(fontsize = title_fontsize))

	decorate_annotation("n_pkg", {
		grid.text("#Packages", y = unit(1, "npc") + unit(7.5, "pt") + 0.5*grobHeight(textGrob("A", gp = gpar(fontsize = title_fontsize))),
			gp = gpar(fontsize = title_fontsize))
	})
	decorate_annotation("sec", {
		grid.text("Loading time", y = unit(1, "npc") + unit(7.5, "pt") + 0.5*grobHeight(textGrob("A", gp = gpar(fontsize = title_fontsize))),
			gp = gpar(fontsize = title_fontsize))
	})

	w = convertWidth(ComplexHeatmap:::width(ht), unit)
	h = convertHeight(ComplexHeatmap:::height(ht), unit)
	invisible(list(width = w, height = h))
}

# dep = function(pkg, verbose = TRUE) {
# 	if(verbose) cat(silver("Loading"), green(pkg), silver("to a new R session... "))
		
# 	if(is.null(env$loaded_ns[[pkg]])) {
		
# 		if(identical(topenv(), .GlobalEnv)) {
# 			if(normalizePath("~") == "/Users/jokergoo") {
# 				cmd = qq("Rscript '/Users/jokergoo/project/pkgndep/inst/extdata/get_dep.R' @{pkg}")
# 			} else {
# 				cmd = qq("Rscript '/desktop-home/guz/project/development/pkgndep/inst/extdata/get_dep.R' @{pkg}")
# 			}
# 		} else {
# 			cmd = qq("'@{normalizePath(c(R.home(), 'bin', 'Rscript'))}' '@{system.file('extdata', 'get_dep.R', package = 'pkgndep')}' @{pkg}")
# 	    }
# 	    oe = try(tb <- read.table(pipe(cmd), header = TRUE, stringsAsFactors = FALSE), silent = TRUE)
# 	    if(inherits(oe, "try-error")) {
# 	    	if(verbose) cat(red(qq("@{pkg} cannot be loaded.\n")))
# 	    	return(NULL)
# 	    } else {
# 		    nr = nrow(tb)
# 		    if(verbose) cat(green(nr), silver(qq("namespace@{ifelse(nr == 1, '', 's')} loaded.\n")))
# 		}
# 		env$loaded_ns[[pkg]] = tb
# 	} else {
# 		tb = env$loaded_ns[[pkg]]
# 		nr = nrow(tb)
# 		if(verbose) cat(green(nr), silver(qq("namespace@{ifelse(nr == 1, '', 's')} loaded.\n")))
# 	}
#     return(tb)
# }

dep = function(pkg, verbose = TRUE) {
	if(verbose) cat(silver("Loading"), green(pkg), silver("to a new R session... "))
		
	if(is.null(env$loaded_ns[[pkg]])) {
		
		tb = r(load_pkg, args = list(pkg = pkg), user_profile = FALSE)
		if(is.null(tb)) {
	    	if(verbose) cat(red(qq("@{pkg} cannot be loaded.\n")))
	    	return(NULL)
	    } else {
	    	for(i in seq_len(ncol(tb))) {
	    		tb[, i] = as.vector(tb[, i])
	    	}
		    nr = nrow(tb)
		    if(verbose) cat(green(nr), silver(qq("namespace@{ifelse(nr == 1, '', 's')} loaded.\n")))
		}
		env$loaded_ns[[pkg]] = tb
	} else {
		tb = env$loaded_ns[[pkg]]
		nr = nrow(tb)
		if(verbose) cat(green(nr), silver(qq("namespace@{ifelse(nr == 1, '', 's')} loaded.\n")))
	}
    return(tb)
}

load_pkg = function(pkg) {
	tmp_file = tempfile()
	sink(tmp_file)
	oe = try(suppressWarnings(suppressPackageStartupMessages(tm <- system.time(library(pkg, character.only = TRUE)))), silent = TRUE)
	sink()
	unlink(tmp_file)

	if(inherits(oe, "try-error")) {
		cat("\n")
	} else {
		foo = sessionInfo()
		df1 = data.frame(pkg = foo$basePkgs, type = rep("basePkgs", length(foo$basePkgs)))
		df2 = data.frame(pkg = names(foo$loadedOnly), type = rep("loadedOnly", length(foo$loadedOnly)))
		df3 = data.frame(pkg = names(foo$otherPkgs), type = rep("otherPkgs", length(foo$otherPkgs)))
		df = rbind(df1, df2, df3)
		df = df[df[, 1] != pkg ,]
		df$tm = tm[3]
		print(df, row.names = FALSE)
	}
}

env = new.env()
env$loaded_ns = list()

.onAttach = function(libname, pkgname) {
    env$loaded_ns = list()
}
jokergoo/pkgndep documentation built on July 6, 2021, 7:56 p.m.