trunk/R/rdep.R

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