/R/strapplyc.R

 1library(tcltk)
 2
 3# x is name of a tcl variable holding list of character vectors
 4tclList2R <- function(x, convert = as.character) {
 5	len <- as.integer(.Tcl(sprintf("llength $%s", x)))
 6	f <- function(i) convert(.Tcl(sprintf("lindex $%s %d", x, i)))
 7	lapply(seq(0, len-1), f)
 8}
 9
10# high performance strapply with hard coded FUN=c.  Guts in tcl.
11strapplyc <- function(X, pattern, backref, ignore.case = FALSE, simplify = FALSE, USE.NAMES = FALSE, engine = getOption("gsubfn.engine")) {
12    if (identical(engine, "R")) return(
13		strapply(X = X, pattern = pattern, FUN = "c", backref = backref, 
14			ignore.case = ignore.case, simplify = simplify, 
15			USE.NAMES = USE.NAMES, engine = engine)
16	)
17	tcl("set", "X", as.tclObj(X))
18	tcl("set", "pattern", pattern)
19	tcl("set", "nocase", if (ignore.case) "-nocase" else "")
20	if (missing(backref) || is.null(backref) || is.na(backref))  backref <- 999
21	tcl("set", "backref", backref)
22	.Tcl("set about [regexp -about -- $pattern]")
23	.Tcl("set about [lindex $about 0]")
24	.Tcl("if { min($about, $backref) <= 0 } { set mn 0 } else { set mn 1 }")
25	.Tcl("set mx [expr min($about, abs($backref))]")
26	s <- paste('set result {}
27		 set k [expr $about + 1]
28		 if { $about == 0 || $about <= -$backref} {
29			 # this leg of the "if" returns everything from regexp so we 
30			 # can avoid the extraction subloop of the "else" leg for speed
31			 foreach item $X {
32				# {*} is new feature in tcl 8.5 to add level of substitution
33				set cmd [list regexp -all -inline {*}$nocase -- $pattern $item] 
34				set res [{*}$cmd]
35				lappend result $res
36			}
37		 } else {
38			foreach item $X {
39				# {*} is new feature in tcl 8.5 that adds level of substitution
40				set cmd [list regexp -all -inline {*}$nocase -- $pattern $item] 
41				set cmdout [{*}$cmd]
42				set imin $mn
43				set imax $mx
44				set res {}
45				while {$imax < [llength $cmdout]} {
46					lappend res [lrange $cmdout $imin $imax]
47					incr imin $k
48					incr imax $k
49				}
50				lappend result [concat {*}$res]
51			}
52		}')
53	.Tcl(s)
54	out <- tclList2R("result")
55
56    result <- sapply(out, identity, simplify = isTRUE(simplify), 
57		USE.NAMES = USE.NAMES)
58    if (is.logical(simplify)) result else {
59		do.call(match.funfn(simplify), result)
60	}
61
62
63}
64