trunk/R/rdep.R

   1
   2 r_bundle_of <- function(pkgname) {
   3     # returns the bundle containing pkgname or NA
   4     bundles <- names(available[!is.na(available[, 'Bundle']), 'Contains'])
   5     # use the first bundle
   6     for (bundle in bundles) {
   7         if (pkgname %in% r_bundle_contains(bundle)) {
   8             return(bundle)
   9         }
  10     }
  11     return(NULL)
  12 }
  13
  14 r_bundle_contains <- function(bundlename) {
  15     return(strsplit(available[bundlename,'Contains'],'[[:space:]]+')[[1]])
  16 }
  17
  18 r_requiring <- function(names) {
  19     for (name in names) {
  20         if (!(name %in% base_pkgs) && !(name %in% rownames(available))) {
  21             bundle <- r_bundle_of(name)
  22             if (!is.null(bundle)) {
  23                 name = bundle
  24                 names <- c(names,bundle)
  25             }
  26         }
  27         if (name %in% rownames(available) && !is.na(available[name,'Contains'])) {
  28             names <- c(names,r_bundle_contains(name))
  29         }
  30     }
  31     # approximately prune first into a smaller availability
  32     candidates <- rownames(available)[sapply(rownames(available)
  33                                             ,function(name)
  34                                                 length(grep(paste(names,collapse='|')
  35                                                            ,available[name,r_depend_fields])) > 0)]
  36     if (length(candidates) == 0) {
  37         return(c())
  38     }
  39     # find a logical index into available of every package/bundle
  40     # whose dependency field contains at least one element of names.
  41     # (this is not particularly easy to read---sorry---but is much faster than
  42     # the alternatives i could think of)
  43     prereq=c()
  44     dep_matches <- function(dep) chomp(gsub('\\([^\\)]+\\)','',dep)) %in% names
  45     any_dep_matches <- function(name,field=NA)
  46                 any(sapply(strsplit(chomp(available[name,field])
  47                                    ,'[[:space:]]*,[[:space:]]*')
  48                           ,dep_matches))
  49
  50     for (field in r_depend_fields) {
  51         matches = sapply(candidates, any_dep_matches, field=field)
  52         if (length(matches) > 0) {
  53             prereq = c(prereq,candidates[matches])
  54         }
  55     }
  56     return(unique(prereq))
  57 }
  58
  59 r_dependencies_of <- function(name=NULL,description=NULL) {
  60     # find the immediate dependencies (children in the dependency graph) of an
  61     # R package
  62     if (!is.null(name) && (name == 'R' || name %in% base_pkgs)) {
  63         return(data.frame())
  64     }
  65     if (is.null(description) && is.null(name)) {
  66         fail('must specify either a description or a name.')
  67     }
  68     if (is.null(description)) {
  69         if (!(name %in% rownames(available))) {
  70             bundle <- r_bundle_of(name)
  71             if (!is.null(bundle)) {
  72                 name <- bundle
  73             } else {
  74                 # unavailable packages don't depend upon anything
  75                 return(data.frame())
  76             }
  77         }
  78         description <- data.frame()
  79         # keep only the interesting fields
  80         for (field in r_depend_fields) {
  81             if (!(field %in% names(available[name,]))) {
  82                 next
  83             }
  84             description[1,field] = available[name,field]
  85         }
  86     }
  87     # extract the dependencies from the description
  88     deps <- data.frame()
  89     for (field in r_depend_fields) {
  90         if (!(field %in% names(description[1,]))) {
  91             next
  92         }
  93         new_deps <- lapply(strsplit(chomp(description[1,field])
  94                                    ,'[[:space:]]*,[[:space:]]*')[[1]]
  95                           ,r_parse_dep_field)
  96         deps <- iterate(lapply(new_deps[!is.na(new_deps)],rbind),deps,rbind)
  97     }
  98     return (deps)
  99 }
 100
 101 r_parse_dep_field <- function(dep) {
 102     if (is.na(dep)) {
 103         return(NA)
 104     }
 105     # remove other comments
 106     dep = gsub('(\\(\\)|\\([[:space:]]*[^<=>!].*\\))','',dep)
 107     # squish spaces
 108     dep = chomp(gsub('[[:space:]]+',' ',dep))
 109     # parse version
 110     pat = '^([^ ()]+) ?(\\( ?([<=>!]+ ?[0-9.-]+) ?\\))?$'
 111     if (!length(grep(pat,dep))) {
 112         fail('R dependency',dep,'does not appear to be well-formed')
 113     }
 114     version = sub(pat,'\\3',dep)
 115     dep = sub(pat,'\\1',dep)
 116     if (!(dep %in% rownames(available))) {
 117         depb <- r_bundle_of(dep)
 118         if (!is.null(depb)) {
 119             dep <- depb
 120         }
 121     }
 122     return(list(name=dep,version=version))
 123 }
 124
 125 r_dependency_closure <- function(fringe, forward_arcs=T) {
 126     # find the transitive closure of the dependencies/prerequisites of some R
 127     # packages
 128     closure <- list()
 129     if (is.data.frame(fringe)) {
 130         fringe <- as.list(fringe$name)
 131     }
 132     fun = function(x) r_dependencies_of(name=x)$name
 133     if (!forward_arcs) {
 134         fun = r_requiring
 135     }
 136     while(length(fringe) > 0) {
 137         # pop off the top
 138         top <- fringe[[1]]
 139         if (length(fringe) > 1) {
 140             fringe <- fringe[2:length(fringe)]
 141         } else {
 142             fringe <- list()
 143         }
 144         src <- pkgname_as_debian(top,binary=F)
 145         if (src == 'R') {
 146             next
 147         }
 148         newdeps <- fun(top)
 149         closure=c(closure,top)
 150         fringe=c(fringe,newdeps)
 151     }
 152     # build order
 153     return(rev(unique(closure,fromLast=T)))
 154 }
 155