Mirror of GNU Guix
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

505 lines
20 KiB

gnu: r: Do not build recommended packages. * gnu/packages/statistics.scm (r)[arguments]: Rename phase "build-recommended-packages-reproducibly" to "build-reproducibly"; add configure flag "--without-recommended-packages". * guix/import/cran.scm (default-r-packages): Remove recommended packages. * gnu/packages/python.scm (python-rpy2)[inputs]: Add r-survival. * gnu/packages/bioinformatics.scm (r-ape)[propagated-inputs]: Add r-lattice and r-nlme. (r-vegan)[propagated-inputs]: Add r-mass. (r-genefilter)[propagated-inputs]: Add r-survival. (r-grohmm)[propagated-inputs]: Add r-mass. (r-bioccheck)[propagated-inputs]: Add r-codetools. (r-summarizedexperiment)[propagated-inputs]: Add r-matrix. (r-topgo)[propagated-inputs]: Add r-lattice. (r-sva)[propagated-inputs]: Add r-mgcv. (r-raremetals2)[propagated-inputs]: Add r-mass. (r-vsn)[propagated-inputs]: Add r-lattice. (r-pcamethods)[propagated-inputs]: Add r-mass. * gnu/packages/bioinformatics.scm (r-ggplot2)[propagated-inputs]: Add r-mass. (r-locfit)[propagated-inputs]: Add r-lattice. (r-coda)[propagated-inputs]: Add r-lattice. (r-irlba)[propagated-inputs]: Add r-matrix. (r-glmnet)[propagated-inputs]: Add r-matrix. (r-e1071)[propagated-inputs]: Add r-class. (r-spams)[propagated-inputs]: Add r-lattice and r-matrix. (r-hmisc)[propagated-inputs]: Add r-cluster, r-foreign, r-lattice, r-nnet, and r-rpart. (r-zoo)[propagated-inputs]: Add r-lattice. (r-mixtools)[propagated-inputs]: Add r-boot and r-mass. (r-flexmix)[propagated-inputs]: Add r-lattice and r-nnet. (r-prabclus)[propagated-inputs]: Add r-mass. (r-fpc)[propagated-inputs]: Add r-class, r-cluster, and r-mass. (r-rcppeigen)[propagated-inputs]: Add r-matrix. (r-matrixmodels)[propagated-inputs]: Add r-matrix. (r-lme4)[propagated-inputs]: Add r-mass and r-nlme. (r-pbkrtest)[propagated-inputs]: Add r-mass and r-matrix. (r-car)[propagated-inputs]: Add r-mass, r-mgcv, and r-nnet. (r-tclust)[propagated-inputs]: Add r-cluster.
5 years ago
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2015, 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
  3. ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
  4. ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
  5. ;;;
  6. ;;; This file is part of GNU Guix.
  7. ;;;
  8. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by
  10. ;;; the Free Software Foundation; either version 3 of the License, or (at
  11. ;;; your option) any later version.
  12. ;;;
  13. ;;; GNU Guix is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;;; GNU General Public License for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  20. (define-module (guix import cran)
  21. #:use-module (ice-9 match)
  22. #:use-module (ice-9 regex)
  23. #:use-module ((ice-9 rdelim) #:select (read-string read-line))
  24. #:use-module (srfi srfi-1)
  25. #:use-module (srfi srfi-26)
  26. #:use-module (srfi srfi-34)
  27. #:use-module (srfi srfi-41)
  28. #:use-module (ice-9 receive)
  29. #:use-module (web uri)
  30. #:use-module (guix memoization)
  31. #:use-module (guix http-client)
  32. #:use-module (guix hash)
  33. #:use-module (guix store)
  34. #:use-module (guix base32)
  35. #:use-module ((guix download) #:select (download-to-store))
  36. #:use-module (guix import utils)
  37. #:use-module ((guix build utils) #:select (find-files))
  38. #:use-module (guix utils)
  39. #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri))
  40. #:use-module (guix upstream)
  41. #:use-module (guix packages)
  42. #:use-module (gnu packages)
  43. #:export (cran->guix-package
  44. bioconductor->guix-package
  45. recursive-import
  46. %cran-updater
  47. %bioconductor-updater
  48. cran-package?
  49. bioconductor-package?
  50. bioconductor-data-package?
  51. bioconductor-experiment-package?))
  52. ;;; Commentary:
  53. ;;;
  54. ;;; Generate a package declaration template for the latest version of an R
  55. ;;; package on CRAN, using the DESCRIPTION file downloaded from
  56. ;;; cran.r-project.org.
  57. ;;;
  58. ;;; Code:
  59. (define string->license
  60. (match-lambda
  61. ("AGPL-3" 'agpl3+)
  62. ("Artistic-2.0" 'artistic2.0)
  63. ("Apache License 2.0" 'asl2.0)
  64. ("BSD_2_clause" 'bsd-2)
  65. ("BSD_2_clause + file LICENSE" 'bsd-2)
  66. ("BSD_3_clause" 'bsd-3)
  67. ("BSD_3_clause + file LICENSE" 'bsd-3)
  68. ("GPL" '(list gpl2+ gpl3+))
  69. ("GPL (>= 2)" 'gpl2+)
  70. ("GPL (>= 3)" 'gpl3+)
  71. ("GPL-2" 'gpl2)
  72. ("GPL-3" 'gpl3)
  73. ("LGPL-2" 'lgpl2.0)
  74. ("LGPL-2.1" 'lgpl2.1)
  75. ("LGPL-3" 'lgpl3)
  76. ("LGPL (>= 2)" 'lgpl2.0+)
  77. ("LGPL (>= 3)" 'lgpl3+)
  78. ("MIT" 'expat)
  79. ("MIT + file LICENSE" 'expat)
  80. ((x) (string->license x))
  81. ((lst ...) `(list ,@(map string->license lst)))
  82. (_ #f)))
  83. (define (description->alist description)
  84. "Convert a DESCRIPTION string into an alist."
  85. (let ((lines (string-split description #\newline))
  86. (parse (lambda (line acc)
  87. (if (string-null? line) acc
  88. ;; Keys usually start with a capital letter and end with
  89. ;; ":". There are some exceptions, unfortunately (such
  90. ;; as "biocViews"). There are no blanks in a key.
  91. (if (string-match "^[A-Za-z][^ :]+:( |\n|$)" line)
  92. ;; New key/value pair
  93. (let* ((pos (string-index line #\:))
  94. (key (string-take line pos))
  95. (value (string-drop line (+ 1 pos))))
  96. (cons (cons key
  97. (string-trim-both value))
  98. acc))
  99. ;; This is a continuation of the previous pair
  100. (match-let ((((key . value) . rest) acc))
  101. (cons (cons key (string-join
  102. (list value
  103. (string-trim-both line))))
  104. rest)))))))
  105. (fold parse '() lines)))
  106. (define (format-inputs names)
  107. "Generate a sorted list of package inputs from a list of package NAMES."
  108. (map (lambda (name)
  109. (list name (list 'unquote (string->symbol name))))
  110. (sort names string-ci<?)))
  111. (define* (maybe-inputs package-inputs #:optional (type 'inputs))
  112. "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a
  113. package definition."
  114. (match package-inputs
  115. (()
  116. '())
  117. ((package-inputs ...)
  118. `((,type (,'quasiquote ,(format-inputs package-inputs)))))))
  119. (define %cran-url "http://cran.r-project.org/web/packages/")
  120. (define %bioconductor-url "http://bioconductor.org/packages/")
  121. ;; The latest Bioconductor release is 3.5. Bioconductor packages should be
  122. ;; updated together.
  123. (define (bioconductor-mirror-url name)
  124. (string-append "https://raw.githubusercontent.com/Bioconductor-mirror/"
  125. name "/release-3.5"))
  126. (define (fetch-description repository name)
  127. "Return an alist of the contents of the DESCRIPTION file for the R package
  128. NAME in the given REPOSITORY, or #f in case of failure. NAME is
  129. case-sensitive."
  130. ;; This API always returns the latest release of the module.
  131. (let ((url (string-append (case repository
  132. ((cran) (string-append %cran-url name))
  133. ((bioconductor) (bioconductor-mirror-url name)))
  134. "/DESCRIPTION")))
  135. (guard (c ((http-get-error? c)
  136. (format (current-error-port)
  137. "error: failed to retrieve package information \
  138. from ~s: ~a (~s)~%"
  139. (uri->string (http-get-error-uri c))
  140. (http-get-error-code c)
  141. (http-get-error-reason c))
  142. #f))
  143. (description->alist (read-string (http-fetch url))))))
  144. (define (listify meta field)
  145. "Look up FIELD in the alist META. If FIELD contains a comma-separated
  146. string, turn it into a list and strip off parenthetic expressions. Return the
  147. empty list when the FIELD cannot be found."
  148. (let ((value (assoc-ref meta field)))
  149. (if (not value)
  150. '()
  151. ;; Strip off parentheses
  152. (let ((items (string-split (regexp-substitute/global
  153. #f "( *\\([^\\)]+\\)) *"
  154. value 'pre 'post)
  155. #\,)))
  156. (remove (lambda (item)
  157. (or (string-null? item)
  158. ;; When there is whitespace inside of items it is
  159. ;; probably because this was not an actual list to
  160. ;; begin with.
  161. (string-any char-set:whitespace item)))
  162. (map string-trim-both items))))))
  163. (define default-r-packages
  164. (list "base"
  165. "compiler"
  166. "grDevices"
  167. "graphics"
  168. "grid"
  169. "methods"
  170. "parallel"
  171. "splines"
  172. "stats"
  173. "stats4"
  174. "tcltk"
  175. "tools"
  176. "translations"
  177. "utils"))
  178. (define (guix-name name)
  179. "Return a Guix package name for a given R package name."
  180. (string-append "r-" (string-map (match-lambda
  181. (#\_ #\-)
  182. (#\. #\-)
  183. (chr (char-downcase chr)))
  184. name)))
  185. (define (needs-fortran? tarball)
  186. "Check if the TARBALL contains Fortran source files."
  187. (define (check pattern)
  188. (parameterize ((current-error-port (%make-void-port "rw+"))
  189. (current-output-port (%make-void-port "rw+")))
  190. (zero? (system* "tar" "--wildcards" "--list" pattern "-f" tarball))))
  191. (or (check "*.f90")
  192. (check "*.f95")
  193. (check "*.f")))
  194. (define (tarball-files-match-pattern? tarball regexp . file-patterns)
  195. "Return #T if any of the files represented by FILE-PATTERNS in the TARBALL
  196. match the given REGEXP."
  197. (call-with-temporary-directory
  198. (lambda (dir)
  199. (let ((pattern (make-regexp regexp)))
  200. (parameterize ((current-error-port (%make-void-port "rw+")))
  201. (apply system* "tar"
  202. "xf" tarball "-C" dir
  203. `("--wildcards" ,@file-patterns)))
  204. (any (lambda (file)
  205. (call-with-input-file file
  206. (lambda (port)
  207. (let loop ()
  208. (let ((line (read-line port)))
  209. (cond
  210. ((eof-object? line) #f)
  211. ((regexp-exec pattern line) #t)
  212. (else (loop))))))))
  213. (find-files dir))))))
  214. (define (needs-zlib? tarball)
  215. "Return #T if any of the Makevars files in the src directory of the TARBALL
  216. contain a zlib linker flag."
  217. (tarball-files-match-pattern?
  218. tarball "-lz"
  219. "*/src/Makevars*" "*/src/configure*" "*/configure*"))
  220. (define (needs-pkg-config? tarball)
  221. "Return #T if any of the Makevars files in the src directory of the TARBALL
  222. reference the pkg-config tool."
  223. (tarball-files-match-pattern?
  224. tarball "pkg-config"
  225. "*/src/Makevars*" "*/src/configure*" "*/configure*"))
  226. (define (description->package repository meta)
  227. "Return the `package' s-expression for an R package published on REPOSITORY
  228. from the alist META, which was derived from the R package's DESCRIPTION file."
  229. (let* ((base-url (case repository
  230. ((cran) %cran-url)
  231. ((bioconductor) %bioconductor-url)))
  232. (uri-helper (case repository
  233. ((cran) cran-uri)
  234. ((bioconductor) bioconductor-uri)))
  235. (name (assoc-ref meta "Package"))
  236. (synopsis (assoc-ref meta "Title"))
  237. (version (assoc-ref meta "Version"))
  238. (license (string->license (assoc-ref meta "License")))
  239. ;; Some packages have multiple home pages. Some have none.
  240. (home-page (match (listify meta "URL")
  241. ((url rest ...) url)
  242. (_ (string-append base-url name))))
  243. (source-url (match (uri-helper name version)
  244. ((url rest ...) url)
  245. ((? string? url) url)
  246. (_ #f)))
  247. (tarball (with-store store (download-to-store store source-url)))
  248. (sysdepends (append
  249. (if (needs-zlib? tarball) '("zlib") '())
  250. (map string-downcase (listify meta "SystemRequirements"))))
  251. (propagate (filter (lambda (name)
  252. (not (member name default-r-packages)))
  253. (lset-union equal?
  254. (listify meta "Imports")
  255. (listify meta "LinkingTo")
  256. (delete "R"
  257. (listify meta "Depends"))))))
  258. (values
  259. `(package
  260. (name ,(guix-name name))
  261. (version ,version)
  262. (source (origin
  263. (method url-fetch)
  264. (uri (,(procedure-name uri-helper) ,name version))
  265. (sha256
  266. (base32
  267. ,(bytevector->nix-base32-string (file-sha256 tarball))))))
  268. ,@(if (not (equal? (string-append "r-" name)
  269. (guix-name name)))
  270. `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
  271. '())
  272. (build-system r-build-system)
  273. ,@(maybe-inputs sysdepends)
  274. ,@(maybe-inputs (map guix-name propagate) 'propagated-inputs)
  275. ,@(maybe-inputs
  276. `(,@(if (needs-fortran? tarball)
  277. '("gfortran") '())
  278. ,@(if (needs-pkg-config? tarball)
  279. '("pkg-config") '()))
  280. 'native-inputs)
  281. (home-page ,(if (string-null? home-page)
  282. (string-append base-url name)
  283. home-page))
  284. (synopsis ,synopsis)
  285. (description ,(beautify-description (or (assoc-ref meta "Description")
  286. "")))
  287. (license ,license))
  288. propagate)))
  289. (define cran->guix-package
  290. (memoize
  291. (lambda* (package-name #:optional (repo 'cran))
  292. "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
  293. s-expression corresponding to that package, or #f on failure."
  294. (and=> (fetch-description repo package-name)
  295. (cut description->package repo <>)))))
  296. (define* (recursive-import package-name #:optional (repo 'cran))
  297. "Generate a stream of package expressions for PACKAGE-NAME and all its
  298. dependencies."
  299. (receive (package . dependencies)
  300. (cran->guix-package package-name repo)
  301. (if (not package)
  302. stream-null
  303. ;; Generate a lazy stream of package expressions for all unknown
  304. ;; dependencies in the graph.
  305. (let* ((make-state (lambda (queue done)
  306. (cons queue done)))
  307. (next (match-lambda
  308. (((next . rest) . done) next)))
  309. (imported (match-lambda
  310. ((queue . done) done)))
  311. (done? (match-lambda
  312. ((queue . done)
  313. (zero? (length queue)))))
  314. (unknown? (lambda* (dependency #:optional (done '()))
  315. (and (not (member dependency
  316. done))
  317. (null? (find-packages-by-name
  318. (guix-name dependency))))))
  319. (update (lambda (state new-queue)
  320. (match state
  321. (((head . tail) . done)
  322. (make-state (lset-difference
  323. equal?
  324. (lset-union equal? new-queue tail)
  325. done)
  326. (cons head done)))))))
  327. (stream-cons
  328. package
  329. (stream-unfold
  330. ;; map: produce a stream element
  331. (lambda (state)
  332. (cran->guix-package (next state) repo))
  333. ;; predicate
  334. (negate done?)
  335. ;; generator: update the queue
  336. (lambda (state)
  337. (receive (package . dependencies)
  338. (cran->guix-package (next state) repo)
  339. (if package
  340. (update state (filter (cut unknown? <>
  341. (cons (next state)
  342. (imported state)))
  343. (car dependencies)))
  344. ;; TODO: Try the other archives before giving up
  345. (update state (imported state)))))
  346. ;; initial state
  347. (make-state (filter unknown? (car dependencies))
  348. (list package-name))))))))
  349. ;;;
  350. ;;; Updater.
  351. ;;;
  352. (define (package->upstream-name package)
  353. "Return the upstream name of the PACKAGE."
  354. (let* ((properties (package-properties package))
  355. (upstream-name (and=> properties
  356. (cut assoc-ref <> 'upstream-name))))
  357. (if upstream-name
  358. upstream-name
  359. (match (package-source package)
  360. ((? origin? origin)
  361. (match (origin-uri origin)
  362. ((or (? string? url) (url _ ...))
  363. (let ((end (string-rindex url #\_))
  364. (start (string-rindex url #\/)))
  365. ;; The URL ends on
  366. ;; (string-append "/" name "_" version ".tar.gz")
  367. (and start end (substring url (+ start 1) end))))
  368. (_ #f)))
  369. (_ #f)))))
  370. (define (latest-cran-release package)
  371. "Return an <upstream-source> for the latest release of PACKAGE."
  372. (define upstream-name
  373. (package->upstream-name package))
  374. (define meta
  375. (fetch-description 'cran upstream-name))
  376. (and meta
  377. (let ((version (assoc-ref meta "Version")))
  378. ;; CRAN does not provide signatures.
  379. (upstream-source
  380. (package (package-name package))
  381. (version version)
  382. (urls (cran-uri upstream-name version))))))
  383. (define (latest-bioconductor-release package)
  384. "Return an <upstream-source> for the latest release of PACKAGE."
  385. (define upstream-name
  386. (package->upstream-name package))
  387. (define meta
  388. (fetch-description 'bioconductor upstream-name))
  389. (and meta
  390. (let ((version (assoc-ref meta "Version")))
  391. ;; Bioconductor does not provide signatures.
  392. (upstream-source
  393. (package (package-name package))
  394. (version version)
  395. (urls (list (bioconductor-uri upstream-name version)))))))
  396. (define (cran-package? package)
  397. "Return true if PACKAGE is an R package from CRAN."
  398. (and (string-prefix? "r-" (package-name package))
  399. ;; Check if the upstream name can be extracted from package uri.
  400. (package->upstream-name package)
  401. ;; Check if package uri(s) are prefixed by "mirror://cran".
  402. (match (and=> (package-source package) origin-uri)
  403. ((? string? uri)
  404. (string-prefix? "mirror://cran" uri))
  405. ((? list? uris)
  406. (any (cut string-prefix? "mirror://cran" <>) uris))
  407. (_ #f))))
  408. (define (bioconductor-package? package)
  409. "Return true if PACKAGE is an R package from Bioconductor."
  410. (let ((predicate (lambda (uri)
  411. (and (string-prefix? "http://bioconductor.org" uri)
  412. ;; Data packages are neither listed in SVN nor on
  413. ;; the Github mirror, so we have to exclude them
  414. ;; from the set of bioconductor packages that can be
  415. ;; updated automatically.
  416. (not (string-contains uri "/data/annotation/"))
  417. ;; Experiment packages are in a separate repository.
  418. (not (string-contains uri "/data/experiment/"))))))
  419. (and (string-prefix? "r-" (package-name package))
  420. (match (and=> (package-source package) origin-uri)
  421. ((? string? uri)
  422. (predicate uri))
  423. ((? list? uris)
  424. (any predicate uris))
  425. (_ #f)))))
  426. (define (bioconductor-data-package? package)
  427. "Return true if PACKAGE is an R data package from Bioconductor."
  428. (let ((predicate (lambda (uri)
  429. (and (string-prefix? "http://bioconductor.org" uri)
  430. (string-contains uri "/data/annotation/")))))
  431. (and (string-prefix? "r-" (package-name package))
  432. (match (and=> (package-source package) origin-uri)
  433. ((? string? uri)
  434. (predicate uri))
  435. ((? list? uris)
  436. (any predicate uris))
  437. (_ #f)))))
  438. (define (bioconductor-experiment-package? package)
  439. "Return true if PACKAGE is an R experiment package from Bioconductor."
  440. (let ((predicate (lambda (uri)
  441. (and (string-prefix? "http://bioconductor.org" uri)
  442. (string-contains uri "/data/experiment/")))))
  443. (and (string-prefix? "r-" (package-name package))
  444. (match (and=> (package-source package) origin-uri)
  445. ((? string? uri)
  446. (predicate uri))
  447. ((? list? uris)
  448. (any predicate uris))
  449. (_ #f)))))
  450. (define %cran-updater
  451. (upstream-updater
  452. (name 'cran)
  453. (description "Updater for CRAN packages")
  454. (pred cran-package?)
  455. (latest latest-cran-release)))
  456. (define %bioconductor-updater
  457. (upstream-updater
  458. (name 'bioconductor)
  459. (description "Updater for Bioconductor packages")
  460. (pred bioconductor-package?)
  461. (latest latest-bioconductor-release)))
  462. ;;; cran.scm ends here