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