branch/double_build/R/rdep.R

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