--- /dev/null
+
+
+r_requiring <- function(names) {
+ # approximately prune first into a smaller availability
+ candidates <- rownames(available)[sapply(rownames(available)
+ ,function(name)
+ length(grep(paste(names,collapse='|')
+ ,available[name,r_depend_fields])) > 0)]
+ if (length(candidates) == 0) {
+ return(c())
+ }
+ # find a logical index into available of every package
+ # whose dependency field contains at least one element of names.
+ # (this is not particularly easy to read---sorry---but is much faster than
+ # the alternatives i could think of)
+ prereq=c()
+ dep_matches <- function(dep) chomp(gsub('\\([^\\)]+\\)','',dep)) %in% names
+ any_dep_matches <- function(name,field=NA)
+ any(sapply(strsplit(chomp(available[name,field])
+ ,'[[:space:]]*,[[:space:]]*')
+ ,dep_matches))
+
+ for (field in r_depend_fields) {
+ matches = sapply(candidates, any_dep_matches, field=field)
+ if (length(matches) > 0) {
+ prereq = c(prereq,candidates[matches])
+ }
+ }
+ return(unique(prereq))
+}
+
+r_dependencies_of <- function(name=NULL,description=NULL) {
+ # find the immediate dependencies (children in the dependency graph) of an
+ # R package
+ if (!is.null(name) && (name == 'R' || name %in% base_pkgs)) {
+ return(data.frame())
+ }
+ if (is.null(description) && is.null(name)) {
+ fail('must specify either a description or a name.')
+ }
+ if (is.null(description)) {
+ if (!(name %in% rownames(available))) {
+ # unavailable packages don't depend upon anything
+ return(data.frame())
+ }
+ description <- data.frame()
+ # keep only the interesting fields
+ for (field in r_depend_fields) {
+ if (!(field %in% names(available[name,]))) {
+ next
+ }
+ description[1,field] = available[name,field]
+ }
+ }
+ # extract the dependencies from the description
+ deps <- data.frame()
+ for (field in r_depend_fields) {
+ if (!(field %in% names(description[1,]))) {
+ next
+ }
+ new_deps <- lapply(strsplit(chomp(description[1,field])
+ ,'[[:space:]]*,[[:space:]]*')[[1]]
+ ,r_parse_dep_field)
+ deps <- iterate(lapply(new_deps[!is.na(new_deps)],rbind),deps,rbind)
+ }
+ return (deps)
+}
+
+r_parse_dep_field <- function(dep) {
+ if (is.na(dep)) {
+ return(NA)
+ }
+ # remove other comments
+ dep = gsub('(\\(\\)|\\([[:space:]]*[^<=>!].*\\))','',dep)
+ # squish spaces
+ dep = chomp(gsub('[[:space:]]+',' ',dep))
+ # parse version
+ pat = '^([^ ()]+) ?(\\( ?([<=>!]+ ?[0-9.-]+) ?\\))?$'
+ if (!length(grep(pat,dep))) {
+ fail('R dependency',dep,'does not appear to be well-formed')
+ }
+ version = sub(pat,'\\3',dep)
+ dep = sub(pat,'\\1',dep)
+ return(list(name=dep,version=version))
+}
+
+r_dependency_closure <- function(fringe, forward_arcs=T) {
+ # find the transitive closure of the dependencies/prerequisites of some R
+ # packages
+ closure <- list()
+ if (is.data.frame(fringe)) {
+ fringe <- as.list(fringe$name)
+ }
+ fun = function(x) r_dependencies_of(name=x)$name
+ if (!forward_arcs) {
+ fun = r_requiring
+ }
+ while(length(fringe) > 0) {
+ # pop off the top
+ top <- fringe[[1]]
+ if (length(fringe) > 1) {
+ fringe <- fringe[2:length(fringe)]
+ } else {
+ fringe <- list()
+ }
+ src <- pkgname_as_debian(top,binary=F)
+ if (src == 'R') {
+ next
+ }
+ newdeps <- fun(top)
+ closure=c(closure,top)
+ fringe=c(fringe,newdeps)
+ }
+ # build order
+ return(rev(unique(closure,fromLast=T)))
+}
+