.emacs.d.git - Gitblit

Chizi123

2018-11-18 76bbd07de7add0f9d13c6914f158d19630fe2f62

commit \| author \| age
76bbd0	1	;;; ob-R.el --- Babel Functions for R -- lexical-binding: t; --
C	2
	3	;; Copyright (C) 2009-2018 Free Software Foundation, Inc.
	4
	5	;; Author: Eric Schulte
	6	;; Dan Davison
	7	;; Keywords: literate programming, reproducible research, R, statistics
	8	;; Homepage: https://orgmode.org
	9
	10	;; This file is part of GNU Emacs.
	11
	12	;; GNU Emacs is free software: you can redistribute it and/or modify
	13	;; it under the terms of the GNU General Public License as published by
	14	;; the Free Software Foundation, either version 3 of the License, or
	15	;; (at your option) any later version.
	16
	17	;; GNU Emacs is distributed in the hope that it will be useful,
	18	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	19	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	20	;; GNU General Public License for more details.
	21
	22	;; You should have received a copy of the GNU General Public License
	23	;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
	24
	25	;;; Commentary:
	26
	27	;; Org-Babel support for evaluating R code
	28
	29	;;; Code:
	30
	31	(require 'cl-lib)
	32	(require 'ob)
	33
	34	(declare-function orgtbl-to-tsv "org-table" (table params))
	35	(declare-function R "ext:essd-r" (&optional start-args))
	36	(declare-function inferior-ess-send-input "ext:ess-inf" ())
	37	(declare-function ess-make-buffer-current "ext:ess-inf" ())
	38	(declare-function ess-eval-buffer "ext:ess-inf" (vis))
	39	(declare-function ess-wait-for-process "ext:ess-inf"
	40	(&optional proc sec-prompt wait force-redisplay))
	41
	42	(defconst org-babel-header-args:R
	43	'((width . :any)
	44	(height . :any)
	45	(bg . :any)
	46	(units . :any)
	47	(pointsize . :any)
	48	(antialias . :any)
	49	(quality . :any)
	50	(compression . :any)
	51	(res . :any)
	52	(type . :any)
	53	(family . :any)
	54	(title . :any)
	55	(fonts . :any)
	56	(version . :any)
	57	(paper . :any)
	58	(encoding . :any)
	59	(pagecentre . :any)
	60	(colormodel . :any)
	61	(useDingbats . :any)
	62	(horizontal . :any)
	63	(results . ((file list vector table scalar verbatim)
	64	(raw html latex org code pp drawer)
	65	(replace silent none append prepend)
	66	(output value graphics))))
	67	"R-specific header arguments.")
	68
	69	(defconst ob-R-safe-header-args
	70	(append org-babel-safe-header-args
	71	'(:width :height :bg :units :pointsize :antialias :quality
	72	:compression :res :type :family :title :fonts
	73	:version :paper :encoding :pagecentre :colormodel
	74	:useDingbats :horizontal))
	75	"Header args which are safe for R babel blocks.
	76
	77	See `org-babel-safe-header-args' for documentation of the format of
	78	this variable.")
	79
	80	(defvar org-babel-default-header-args:R '())
	81	(put 'org-babel-default-header-args:R 'safe-local-variable
	82	(org-babel-header-args-safe-fn ob-R-safe-header-args))
	83
	84	(defcustom org-babel-R-command "R --slave --no-save"
	85	"Name of command to use for executing R code."
	86	:group 'org-babel
	87	:version "24.1"
	88	:type 'string)
	89
	90	(defvar ess-current-process-name) ; dynamically scoped
	91	(defvar ess-local-process-name) ; dynamically scoped
	92	(defun org-babel-edit-prep:R (info)
	93	(let ((session (cdr (assq :session (nth 2 info)))))
	94	(when (and session
	95	(string-prefix-p "*" session)
	96	(string-suffix-p "*" session))
	97	(org-babel-R-initiate-session session nil))))
	98
	99	;; The usage of utils::read.table() ensures that the command
	100	;; read.table() can be found even in circumstances when the utils
	101	;; package is not in the search path from R.
	102	(defconst ob-R-transfer-variable-table-with-header
	103	"%s <- local({
	104	con <- textConnection(
	105	%S
	106	)
	107	res <- utils::read.table(
	108	con,
	109	header = %s,
	110	row.names = %s,
	111	sep = \"\\t\",
	112	as.is = TRUE
	113	)
	114	close(con)
	115	res
	116	})"
	117	"R code used to transfer a table defined as a variable from org to R.
	118
	119	This function is used when the table contains a header.")
	120
	121	(defconst ob-R-transfer-variable-table-without-header
	122	"%s <- local({
	123	con <- textConnection(
	124	%S
	125	)
	126	res <- utils::read.table(
	127	con,
	128	header = %s,
	129	row.names = %s,
	130	sep = \"\\t\",
	131	as.is = TRUE,
	132	fill = TRUE,
	133	col.names = paste(\"V\", seq_len(%d), sep =\"\")
	134	)
	135	close(con)
	136	res
	137	})"
	138	"R code used to transfer a table defined as a variable from org to R.
	139
	140	This function is used when the table does not contain a header.")
	141
	142	(defun org-babel-expand-body:R (body params &optional _graphics-file)
	143	"Expand BODY according to PARAMS, return the expanded body."
	144	(mapconcat 'identity
	145	(append
	146	(when (cdr (assq :prologue params))
	147	(list (cdr (assq :prologue params))))
	148	(org-babel-variable-assignments:R params)
	149	(list body)
	150	(when (cdr (assq :epilogue params))
	151	(list (cdr (assq :epilogue params)))))
	152	"\n"))
	153
	154	(defun org-babel-execute:R (body params)
	155	"Execute a block of R code.
	156	This function is called by `org-babel-execute-src-block'."
	157	(save-excursion
	158	(let* ((result-params (cdr (assq :result-params params)))
	159	(result-type (cdr (assq :result-type params)))
	160	(session (org-babel-R-initiate-session
	161	(cdr (assq :session params)) params))
	162	(graphics-file (and (member "graphics" (assq :result-params params))
	163	(org-babel-graphical-output-file params)))
	164	(colnames-p (unless graphics-file (cdr (assq :colnames params))))
	165	(rownames-p (unless graphics-file (cdr (assq :rownames params))))
	166	(full-body
	167	(let ((inside
	168	(list (org-babel-expand-body:R body params graphics-file))))
	169	(mapconcat 'identity
	170	(if graphics-file
	171	(append
	172	(list (org-babel-R-construct-graphics-device-call
	173	graphics-file params))
	174	inside
	175	(list "},error=function(e){plot(x=-1:1, y=-1:1, type='n', xlab='', ylab='', axes=FALSE); text(x=0, y=0, labels=e$message, col='red'); paste('ERROR', e$message, sep=' : ')}); dev.off()"))
	176	inside)
	177	"\n")))
	178	(result
	179	(org-babel-R-evaluate
	180	session full-body result-type result-params
	181	(or (equal "yes" colnames-p)
	182	(org-babel-pick-name
	183	(cdr (assq :colname-names params)) colnames-p))
	184	(or (equal "yes" rownames-p)
	185	(org-babel-pick-name
	186	(cdr (assq :rowname-names params)) rownames-p)))))
	187	(if graphics-file nil result))))
	188
	189	(defun org-babel-prep-session:R (session params)
	190	"Prepare SESSION according to the header arguments specified in PARAMS."
	191	(let* ((session (org-babel-R-initiate-session session params))
	192	(var-lines (org-babel-variable-assignments:R params)))
	193	(org-babel-comint-in-buffer session
	194	(mapc (lambda (var)
	195	(end-of-line 1) (insert var) (comint-send-input nil t)
	196	(org-babel-comint-wait-for-output session)) var-lines))
	197	session))
	198
	199	(defun org-babel-load-session:R (session body params)
	200	"Load BODY into SESSION."
	201	(save-window-excursion
	202	(let ((buffer (org-babel-prep-session:R session params)))
	203	(with-current-buffer buffer
	204	(goto-char (process-mark (get-buffer-process (current-buffer))))
	205	(insert (org-babel-chomp body)))
	206	buffer)))
	207
	208	;; helper functions
	209
	210	(defun org-babel-variable-assignments:R (params)
	211	"Return list of R statements assigning the block's variables."
	212	(let ((vars (org-babel--get-vars params)))
	213	(mapcar
	214	(lambda (pair)
	215	(org-babel-R-assign-elisp
	216	(car pair) (cdr pair)
	217	(equal "yes" (cdr (assq :colnames params)))
	218	(equal "yes" (cdr (assq :rownames params)))))
	219	(mapcar
	220	(lambda (i)
	221	(cons (car (nth i vars))
	222	(org-babel-reassemble-table
	223	(cdr (nth i vars))
	224	(cdr (nth i (cdr (assq :colname-names params))))
	225	(cdr (nth i (cdr (assq :rowname-names params)))))))
	226	(number-sequence 0 (1- (length vars)))))))
	227
	228	(defun org-babel-R-quote-tsv-field (s)
	229	"Quote field S for export to R."
	230	(if (stringp s)
	231	(concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"")
	232	(format "%S" s)))
	233
	234	(defun org-babel-R-assign-elisp (name value colnames-p rownames-p)
	235	"Construct R code assigning the elisp VALUE to a variable named NAME."
	236	(if (listp value)
	237	(let* ((lengths (mapcar 'length (cl-remove-if-not 'sequencep value)))
	238	(max (if lengths (apply 'max lengths) 0))
	239	(min (if lengths (apply 'min lengths) 0)))
	240	;; Ensure VALUE has an orgtbl structure (depth of at least 2).
	241	(unless (listp (car value)) (setq value (list value)))
	242	(let ((file (orgtbl-to-tsv value '(:fmt org-babel-R-quote-tsv-field)))
	243	(header (if (or (eq (nth 1 value) 'hline) colnames-p)
	244	"TRUE" "FALSE"))
	245	(row-names (if rownames-p "1" "NULL")))
	246	(if (= max min)
	247	(format ob-R-transfer-variable-table-with-header
	248	name file header row-names)
	249	(format ob-R-transfer-variable-table-without-header
	250	name file header row-names max))))
	251	(cond ((integerp value) (format "%s <- %s" name (concat (number-to-string value) "L")))
	252	((floatp value) (format "%s <- %s" name value))
	253	((stringp value) (format "%s <- %S" name (org-no-properties value)))
	254	(t (format "%s <- %S" name (prin1-to-string value))))))
	255
	256
	257	(defvar ess-ask-for-ess-directory) ; dynamically scoped
	258	(defun org-babel-R-initiate-session (session params)
	259	"If there is not a current R process then create one."
	260	(unless (string= session "none")
	261	(let ((session (or session "R"))
	262	(ess-ask-for-ess-directory
	263	(and (boundp 'ess-ask-for-ess-directory)
	264	ess-ask-for-ess-directory
	265	(not (cdr (assq :dir params))))))
	266	(if (org-babel-comint-buffer-livep session)
	267	session
	268	(save-window-excursion
	269	(when (get-buffer session)
	270	;; Session buffer exists, but with dead process
	271	(set-buffer session))
	272	(require 'ess) (R)
	273	(let ((R-proc (get-process (or ess-local-process-name
	274	ess-current-process-name))))
	275	(while (process-get R-proc 'callbacks)
	276	(ess-wait-for-process R-proc)))
	277	(rename-buffer
	278	(if (bufferp session)
	279	(buffer-name session)
	280	(if (stringp session)
	281	session
	282	(buffer-name))))
	283	(current-buffer))))))
	284
	285	(defun org-babel-R-associate-session (session)
	286	"Associate R code buffer with an R session.
	287	Make SESSION be the inferior ESS process associated with the
	288	current code buffer."
	289	(setq ess-local-process-name
	290	(process-name (get-buffer-process session)))
	291	(ess-make-buffer-current))
	292
	293	(defvar org-babel-R-graphics-devices
	294	'((:bmp "bmp" "filename")
	295	(:jpg "jpeg" "filename")
	296	(:jpeg "jpeg" "filename")
	297	(:tikz "tikz" "file")
	298	(:tiff "tiff" "filename")
	299	(:png "png" "filename")
	300	(:svg "svg" "file")
	301	(:pdf "pdf" "file")
	302	(:ps "postscript" "file")
	303	(:postscript "postscript" "file"))
	304	"An alist mapping graphics file types to R functions.
	305
	306	Each member of this list is a list with three members:
	307	1. the file extension of the graphics file, as an elisp :keyword
	308	2. the R graphics device function to call to generate such a file
	309	3. the name of the argument to this function which specifies the
	310	file to write to (typically \"file\" or \"filename\")")
	311
	312	(defun org-babel-R-construct-graphics-device-call (out-file params)
	313	"Construct the call to the graphics device."
	314	(let* ((allowed-args '(:width :height :bg :units :pointsize
	315	:antialias :quality :compression :res
	316	:type :family :title :fonts :version
	317	:paper :encoding :pagecentre :colormodel
	318	:useDingbats :horizontal))
	319	(device (file-name-extension out-file))
	320	(device-info (or (assq (intern (concat ":" device))
	321	org-babel-R-graphics-devices)
	322	(assq :png org-babel-R-graphics-devices)))
	323	(extra-args (cdr (assq :R-dev-args params))) filearg args)
	324	(setq device (nth 1 device-info))
	325	(setq filearg (nth 2 device-info))
	326	(setq args (mapconcat
	327	(lambda (pair)
	328	(if (member (car pair) allowed-args)
	329	(format ",%s=%S"
	330	(substring (symbol-name (car pair)) 1)
	331	(cdr pair)) ""))
	332	params ""))
	333	(format "%s(%s=\"%s\"%s%s%s); tryCatch({"
	334	device filearg out-file args
	335	(if extra-args "," "") (or extra-args ""))))
	336
	337	(defconst org-babel-R-eoe-indicator "'org_babel_R_eoe'")
	338	(defconst org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"")
	339
	340	(defconst org-babel-R-write-object-command "{
	341	function(object,transfer.file) {
	342	object
	343	invisible(
	344	if (
	345	inherits(
	346	try(
	347	{
	348	tfile<-tempfile()
	349	write.table(object, file=tfile, sep=\"\\t\",
	350	na=\"nil\",row.names=%s,col.names=%s,
	351	quote=FALSE)
	352	file.rename(tfile,transfer.file)
	353	},
	354	silent=TRUE),
	355	\"try-error\"))
	356	{
	357	if(!file.exists(transfer.file))
	358	file.create(transfer.file)
	359	}
	360	)
	361	}
	362	}(object=%s,transfer.file=\"%s\")"
	363	"A template for an R command to evaluate a block of code and write the result to a file.
	364
	365	Has four %s escapes to be filled in:
	366	1. Row names, \"TRUE\" or \"FALSE\"
	367	2. Column names, \"TRUE\" or \"FALSE\"
	368	3. The code to be run (must be an expression, not a statement)
	369	4. The name of the file to write to")
	370
	371	(defun org-babel-R-evaluate
	372	(session body result-type result-params column-names-p row-names-p)
	373	"Evaluate R code in BODY."
	374	(if session
	375	(org-babel-R-evaluate-session
	376	session body result-type result-params column-names-p row-names-p)
	377	(org-babel-R-evaluate-external-process
	378	body result-type result-params column-names-p row-names-p)))
	379
	380	(defun org-babel-R-evaluate-external-process
	381	(body result-type result-params column-names-p row-names-p)
	382	"Evaluate BODY in external R process.
	383	If RESULT-TYPE equals `output' then return standard output as a
	384	string. If RESULT-TYPE equals `value' then return the value of the
	385	last statement in BODY, as elisp."
	386	(cl-case result-type
	387	(value
	388	(let ((tmp-file (org-babel-temp-file "R-")))
	389	(org-babel-eval org-babel-R-command
	390	(format org-babel-R-write-object-command
	391	(if row-names-p "TRUE" "FALSE")
	392	(if column-names-p
	393	(if row-names-p "NA" "TRUE")
	394	"FALSE")
	395	(format "{function ()\n{\n%s\n}}()" body)
	396	(org-babel-process-file-name tmp-file 'noquote)))
	397	(org-babel-R-process-value-result
	398	(org-babel-result-cond result-params
	399	(with-temp-buffer
	400	(insert-file-contents tmp-file)
	401	(org-babel-chomp (buffer-string) "\n"))
	402	(org-babel-import-elisp-from-file tmp-file '(16)))
	403	column-names-p)))
	404	(output (org-babel-eval org-babel-R-command body))))
	405
	406	(defvar ess-eval-visibly-p)
	407
	408	(defun org-babel-R-evaluate-session
	409	(session body result-type result-params column-names-p row-names-p)
	410	"Evaluate BODY in SESSION.
	411	If RESULT-TYPE equals `output' then return standard output as a
	412	string. If RESULT-TYPE equals `value' then return the value of the
	413	last statement in BODY, as elisp."
	414	(cl-case result-type
	415	(value
	416	(with-temp-buffer
	417	(insert (org-babel-chomp body))
	418	(let ((ess-local-process-name
	419	(process-name (get-buffer-process session)))
	420	(ess-eval-visibly-p nil))
	421	(ess-eval-buffer nil)))
	422	(let ((tmp-file (org-babel-temp-file "R-")))
	423	(org-babel-comint-eval-invisibly-and-wait-for-file
	424	session tmp-file
	425	(format org-babel-R-write-object-command
	426	(if row-names-p "TRUE" "FALSE")
	427	(if column-names-p
	428	(if row-names-p "NA" "TRUE")
	429	"FALSE")
	430	".Last.value" (org-babel-process-file-name tmp-file 'noquote)))
	431	(org-babel-R-process-value-result
	432	(org-babel-result-cond result-params
	433	(with-temp-buffer
	434	(insert-file-contents tmp-file)
	435	(org-babel-chomp (buffer-string) "\n"))
	436	(org-babel-import-elisp-from-file tmp-file '(16)))
	437	column-names-p)))
	438	(output
	439	(mapconcat
	440	'org-babel-chomp
	441	(butlast
	442	(delq nil
	443	(mapcar
	444	(lambda (line) (when (> (length line) 0) line))
	445	(mapcar
	446	(lambda (line) ;; cleanup extra prompts left in output
	447	(if (string-match
	448	"^\$[>+.]\\([ ][>.+]\$*[ ]\\)"
	449	(car (split-string line "\n")))
	450	(substring line (match-end 1))
	451	line))
	452	(org-babel-comint-with-output (session org-babel-R-eoe-output)
	453	(insert (mapconcat 'org-babel-chomp
	454	(list body org-babel-R-eoe-indicator)
	455	"\n"))
	456	(inferior-ess-send-input)))))) "\n"))))
	457
	458	(defun org-babel-R-process-value-result (result column-names-p)
	459	"R-specific processing of return value.
	460	Insert hline if column names in output have been requested."
	461	(if column-names-p
	462	(cons (car result) (cons 'hline (cdr result)))
	463	result))
	464
	465	(provide 'ob-R)
	466
	467
	468
	469	;;; ob-R.el ends here