The outcome is a little color theme called rappster. The nice thing with those color themes is that you can make your syntax highlighting settings portable as you can simply import the theme of your choice in another instance of Eclipse, e.g. when updating to a newer version.

Unfortunately, the StatET editor is not available for previews at Eclipse Color Themes website, so I’ve added a couple of screenshots of how the theme handles the syntax highlighting of R code:

Screenshot 1

Screenshot 2

Instructions for installation

If you don’t have a recent Eclipse installation together with the StatET plugin yet, then

1. go to http://www.eclipse.org/downloads/, grab the desired version of the Classic Installer (Eclipse Classic 3.x.x)
2. Open up Eclipse, select a working directory.
3. Go to [Window > Preferences > Install New Software...], enter the StatET URL that is associated to your Eclipse version (check this at http://www.walware.de/it/statet/installation.mframe), click the [Add] button, assign a name (StatET) and click your way through the further installation process.
4. Next you need to set up at least one R run configuration. This is more or less self explanatory once you find [Run > Run Configurations...] and double click on the category [R Console]. If you ran the configuration once, it shows up in the run configurations short cuts list (little black arrow next the the bigger green/white arrow button in Eclipse’s icon bar.
5. Create an R project in the Package Explorer/Project Explorer (depends on perspective): right click, then [New > Other > StatET > R project]. Confirm the switch to the StatET perspective.
6. Create an R script file in your R project: [New > R script file].

################################
###### Install Eclipse Marketplace  ####
################################

1. Go to [Help > Install New Software...] and select the entry in the drop-down menu [Work with:] that corresponds to the identifier of the respective Eclipse version
   (e.g. Helios, Indigo etc.; for Indigo, this would be: Indigo – http://download.eclipse.org/releases/indigo).
2. Find category [General Purpose Tools], expand it, find sub-category [Marketplace Client], check its check box, click on the [Next >] button, click on it again in the next screen that appears, accept the terms of license agreement in the next screen that appears, then finally click on the [Finish] button.
3. Wait for the installation to complete and restart Eclipse by clicking on button [Restart Now].

######################################
##### Install Eclipse Plugin Color Theme  #####
######################################

This plugin enables the use of predefined color themes for text editors. The website of the maintainers can be found at http://www.eclipsecolorthemes.org/

1. Go to [Help > Eclipse Marketplace] and enter Color Theme in the text box [Find:] and hit the [ENTER] key
2. Find entry [Eclipse Color Theme] and click on the [Install] button, then the [Next] button, accept the terms of the license agreement and click the [Finish] button
3. In case of a security warning, accept the further installation by clicking on the [OK] button.
4. Wait for the installation to complete and restart Eclipse by clicking on button [Restart Now].

#################################
##### Install Color Theme rappster  #####
#################################

1. Go to http://www.eclipsecolorthemes.org/?list=all&q=rappster and download the XML file associated to the color theme.
2. In Eclipse, go to [Window > Preferences > General > Appearance > Color Theme] and click on button [Import a theme...]
3. Select the XML file you just downloaded (theme-6130.xml)
4. In the left pane ([Theme:]), select color theme rappster and click the [OK] button.
5. Open up an arbitrary R script to see the effects of setting the rappster color theme.

Have fun!

After my last post about running your R infrastructure from an USB drive, he commented on my function that would update the Windows PATH (which is at least important for R and Rtools).

Now I found some time to polish it a little. Feel free to test (there’s a little example script) and comment on it on GitHub!

UPDATE 2012-03-07

Some further tweaking:

• Generic function: pathWindowsUpdate.R
• Method for class “list”: pathWindowsUpdate.R
• Example: pathWindowsUpdate.R

Note: you do need to other functions/methods in R

Greetz

In order to connect my R related stuff to a webserver and MySQL I went all the way from using xampp to setting up my own (W)AMPP  (Apache MySQL PHP Perl) to finally back to using xampp. And I’m quite happy about this very last switch to xampp!

Why I like xampp

• it’s open-source and actively maintained (thanks to the guys over at ApacheFriends.org!)
• it can be run as a portable app from an USB device
• it’s hassle free when you want to use an AMPP bundle but don’t like to spend your time configuring the whole thing

Why I parted from xampp

The reason I parted from xampp in the first place was the fact that I thought that the latest RMySQL version that is up on CRAN only seems to like MySQL version 5.0.67 (dating back to 2008-08-04). This forced my to use a way outdated version of xampp (version 1.6.8).

So at some point I decided to set up my own (W)AMPP bundle. It’s not that hard, but you do need to spend some time aligning config files. For those interested, I’ve written a little manual on how to do this on Windows. When you read it, please have in mind that I just scratched it down for my own purpose. It’s not really polished

Why I switched back to xampp

Yesterday I found out that RMySQL indeed connects to any MySQL version if you’re fine with some initial copy and pasting of MySQL files. Unfortunately, this info is not readily available (neither on CRAN nor under the provided URL), at least not for Windows. I actually found it on Stack Overflow (thanks to Yuri) which is becoming one of my favorite resources for programming related information. I’ve adapted it a little to fit my needs.

How to use RMySQL with an arbitrary version of MySQL

Here’s the walk through for a fully portable installation. It assumes you have a directory called Apps directly below your USB drive (<DRIVE>)

1. Get the latest portable xampp (here) and put it on your USB drive (mine lives here: <DRIVE>\Apps\xampp\1.7.7)
2. Get the latest RTools (here) and install it to your USB drive (mine lives like: <DRIVE>\Apps\Rtools\2.14). Be sure that the following paths are included in your Windows PATH variable:
   <DRIVE>\Apps\Rtools\2.14\bin
   <DRIVE>\Apps\Rtools\2.14\MinGW\bin
   <DRIVE>\Apps\Rtools\2.14\MinGW64\bin
3. Set MYSQL_HOME
   There are some alternatives here:
   a) You create or edite file <DRIVE>\Apps\R\R-2.14.0\etc\Renviron.site and add a line:
   MYSQL_HOME=<DRIVE>\Apps\xampp\1.7.7\mysql
   b) In case you use Eclipse (which I still favor over RStudio exactly because of features like this) you can set an environment variable directly in your R Run Configuration:
   
   
4. copy
   <DRIVE>\Apps\xampp\1.7.7\mysql\lib\libmysql.lib
   to
   <DRIVE>\Apps\xampp\1.7.7\mysql\lib\opt\
   to meet dependencies of RMySQL.
5. copy
   <DRIVE>\Apps\xampp\1.7.7\mysql\lib\libmysql.dll
   to
   <DRIVE>\Apps\R\R-2.14.0\bin\ (64 bit)
   or to
   <DRIVE>\Apps\R\R-2.14.0\bin\i386\ (32 bit)
   or to
   C:\Windows\System32.
6. run install.packages()
   

   install.packages("RMySQL",
       type="source",
       lib="<DRIVE>\Apps\R\R-2.14.0\library",
       destdir="<DRIVE>\Apps\R\R-2.14.0\destdir"
   )
   

   If the last step finishes without any errors, then you’re good to go. Otherwise probably something just went wrong with file paths.

   Greetz!

Eventually running the entire Windows OS off a USB drive would be nice (not talking about running it as a Virtual Machine, but to have a bootable Windows on USB), so: any hints appreciated

My current R devel infrastructure consists of

• R 2.14.0 (set up as portable)
• Eclipse 3.7 (set up as portable)
• StatET Plugin for Eclipse (integrates R into Eclipse)
• Rtools 2.14 (set up as portable)
• MikTeX 2.9 Portable (true portable)
• LyX 2.0.2 (set up as portable; make sure you grab the LyX-2.0.x.y-Installer-Bundle.exe as it contains Ghostview and other important stuff)

Thanks to everyone providing and maintaing those tools!

When I say ‘set up as portable’, that means I simply took the regular installer, but instead of installing to “C:\Program Files\”, I choose a directory on my USB device. This works (at least for me) surprisingly often. I guess the crucial part is if the respective application requires some MS Windows registry entry or not. If not, then you’re fine with running it in “portable mode”.

Kind of the most important aspect when running portable apps is that you need to turn absolute paths into relative paths for crucial system components.

Regarding Eclipse, R, MikTeX and LyX, this is not a problem in case you are fine with a few initial tweaks.

• You need to change ‘<LYXDIR>/Ressource/lyxrc.dist’ in order to account for MikTeX’s portable nature. Here’s my last line of that file:
  \path_prefix “$LyXDir\bin;$LyXDir\python;$LyXDir\imagemagick;$LyXDir\ghostscript;$LyXDir\..\..\MiKTeX\2.9\miktex\bin”
• You need to/should write some wrapper functions that give you the relative paths to portable R’s library and destdir folder (which you probably want to be on your USB device as well; per default R installs packages to your harddrive, thus they are “lost” if you switch computers)

Yet, I’ve struggled with Rtools quite a while because I didn’t know how to alter the Windows System PATH based on some script, preferably an R script. Duncan Murdoch sent me some information about the MS Windows registry key that needs to be altered and AFAIU that’s how it’s done when you run the Rools Installer on Windows and opt that you’re fine with the installer altering your path. However, I didn’t feel up to the task of tweaking the registry. In case anyone is interested, this is what Duncan told me:

“We use the Inno Setup installer; it has a function for this.  Here’s the code used:

Root: HKLM; Subkey: SYSTEM\CurrentControlSet\Control\Session Manager\Environment; ValueType: expandsz; ValueName: PATH; ValueData: “{code:getNewPath}”; Tasks: setPath “

Now, yesterday while checking out the new knitr package from Yihui (very nice work by the way! And while where at it: props to Tal Galili for providing www.r-bloggers.com; great source of info, go check it out!), I came across his little R script add-R-path-win.R that does exactly what I was looking for. I adapted it a little to fit my needs. You can find it at my GitHub repo:

https://github.com/Songpants/RappsterMisc/blob/master/R/pathWindowsUpdate.R

For me, being able to compute such an index is the crucial part in order to actually manage such nested structures (which are very helpful in a lot of scenarios where formal classes are too inflexible). What you need to master are a) being able to select a specific branch in the nested list and b) being able to update it (e.g. adding new branches). A use case would be parsing a config file format to a nested list structure.

Initially, I tried to get the job done by recursively traversing the branch structure, but that turned out to be really messy and inefficient.

Basically, the current approach is all about mimicing what ‘str()’ does and putting this into a data frame structure:

x str(x)
List of 1
$ a:List of 2
..$ a.1: int [1:3] 1 2 3
..$ a.2: logi TRUE

At this point, I’ll simply present you what the result of indexing such nested structure looks like. As I don’t have a Github repository set up yet, I’ll put the source code at the very end. Of course, there’s a lot of overhead since it’s based on a lot of regular expression stuff. If you have any suggestions for improvement, you’re more than welcome to tell me!

I’m very sorry for the messed up indentation, but I’ve tried twice. WordPress keeps messing it up somehow. Suggestions on how to avoid this greatly appreciated.

Example list

setClass("TESTCLASS_X", representation=representation(a="numeric"))
setRefClass("TESTCLASS_Y", fields=list(a="numeric"))

src a=list(
a.1=list(a.1.1 = 1, a.1.2 = 1:5, a.1.3 = integer(0)),
a.2=list(a.2.1="a", a.2.2=c("a", "b", "c", "d", "e"), a.2.3=character()),
a.3=list(a.3.1=1.5, a.3.2=c(1.5, 2.5), a.3.3=numeric()),
a.4=list(a.4.1=1+1i, a.4.2=c(0.1+0.3i, 0.2+0.2i, 0.1+0.1i), a.4.3=complex()),
a.5=list(a.5.1 = TRUE, a.5.2 = c(TRUE, TRUE, TRUE), a.5.3 = logical())
),
b=list(
b.1=list(
b.1.1=list(b.1.1.1 =matrix(1, ncol=1),
b.1.1.2=matrix(c(1:4), ncol=2, dimnames=list(NULL, c("a","b"))),
b.1.1.3=matrix()
),
b.1.2=list(b.1.2.1=data.frame(1), b.1.2.2=data.frame(a=1:3, b=1:3),
b.1.2.3=data.frame()
)
),
b.2=list(
b.2.1=list(b.2.1.1=list(a=1), b.2.1.2=list(a=1:2, b=letters[1:2]),
b.2.1.3=list(a=1:2, b="a", c=1:3, d=FALSE, e=1:5), b.2.1.4=list()
)
)
),
c=list(
c.1=list(c.1.1=new.env(), c.1.2=new("TESTCLASS_X", a=1:5),
c.1.3=new("TESTCLASS_Y", a=1:5))
)
)

After indexing

> objectIndex(src=src)
name pos is.top is.bottom       class is.s4  dim
1                      a   1   TRUE     FALSE        list FALSE    5
2                  a/a.1   2  FALSE     FALSE        list FALSE    3
3            a/a.1/a.1.1   3  FALSE      TRUE     numeric FALSE    1
4            a/a.1/a.1.2   3  FALSE      TRUE     integer FALSE    5
5            a/a.1/a.1.3   3  FALSE      TRUE     integer FALSE    0
6                  a/a.2   2  FALSE     FALSE        list FALSE    3
7            a/a.2/a.2.1   3  FALSE      TRUE   character FALSE    1
8            a/a.2/a.2.2   3  FALSE      TRUE   character FALSE    5
9            a/a.2/a.2.3   3  FALSE      TRUE   character FALSE    0
10                 a/a.3   2  FALSE     FALSE        list FALSE    3
11           a/a.3/a.3.1   3  FALSE      TRUE     numeric FALSE    1
12           a/a.3/a.3.2   3  FALSE      TRUE     numeric FALSE    2
13           a/a.3/a.3.3   3  FALSE      TRUE     numeric FALSE    0
14                 a/a.4   2  FALSE     FALSE        list FALSE    3
15           a/a.4/a.4.1   3  FALSE      TRUE     complex FALSE    1
16           a/a.4/a.4.2   3  FALSE      TRUE     complex FALSE    3
17           a/a.4/a.4.3   3  FALSE      TRUE     complex FALSE    0
18                 a/a.5   2  FALSE     FALSE        list FALSE    3
19           a/a.5/a.5.1   3  FALSE      TRUE     logical FALSE    1
20           a/a.5/a.5.2   3  FALSE      TRUE     logical FALSE    3
21           a/a.5/a.5.3   3  FALSE      TRUE     logical FALSE    0
22                     b   1   TRUE     FALSE        list FALSE    2
23                 b/b.1   2  FALSE     FALSE        list FALSE    2
24           b/b.1/b.1.1   3  FALSE     FALSE        list FALSE    3
25   b/b.1/b.1.1/b.1.1.1   4  FALSE      TRUE      matrix FALSE  1-1
26   b/b.1/b.1.1/b.1.1.2   4  FALSE      TRUE      matrix FALSE  2-2
27   b/b.1/b.1.1/b.1.1.3   4  FALSE      TRUE      matrix FALSE  1-1
28           b/b.1/b.1.2   3  FALSE     FALSE        list FALSE    3
29   b/b.1/b.1.2/b.1.2.1   4  FALSE      TRUE  data.frame FALSE  1-1
30   b/b.1/b.1.2/b.1.2.2   4  FALSE      TRUE  data.frame FALSE  3-2
31   b/b.1/b.1.2/b.1.2.3   4  FALSE      TRUE  data.frame FALSE  0-0
32                 b/b.2   2  FALSE     FALSE        list FALSE    1
33           b/b.2/b.2.1   3  FALSE     FALSE        list FALSE    4
34   b/b.2/b.2.1/b.2.1.1   4  FALSE     FALSE        list FALSE    1
35 b/b.2/b.2.1/b.2.1.1/a   5  FALSE      TRUE     numeric FALSE    1
36   b/b.2/b.2.1/b.2.1.2   4  FALSE     FALSE        list FALSE    2
37 b/b.2/b.2.1/b.2.1.2/a   5  FALSE      TRUE     integer FALSE    2
38 b/b.2/b.2.1/b.2.1.2/b   5  FALSE      TRUE   character FALSE    2
39   b/b.2/b.2.1/b.2.1.3   4  FALSE     FALSE        list FALSE    5
40 b/b.2/b.2.1/b.2.1.3/a   5  FALSE      TRUE     integer FALSE    2
41 b/b.2/b.2.1/b.2.1.3/b   5  FALSE      TRUE   character FALSE    1
42 b/b.2/b.2.1/b.2.1.3/c   5  FALSE      TRUE     integer FALSE    3
43 b/b.2/b.2.1/b.2.1.3/d   5  FALSE      TRUE     logical FALSE    1
44 b/b.2/b.2.1/b.2.1.3/e   5  FALSE      TRUE     integer FALSE    5
45   b/b.2/b.2.1/b.2.1.4   4  FALSE     FALSE        list FALSE    0
46                     c   1   TRUE     FALSE        list FALSE    1
47                 c/c.1   2  FALSE     FALSE        list FALSE    3
48           c/c.1/c.1.1   3  FALSE      TRUE environment FALSE
49           c/c.1/c.1.2   3  FALSE      TRUE TESTCLASS_X  TRUE    1
50           c/c.1/c.1.3   3  FALSE      TRUE TESTCLASS_Y  TRUE    1

> objectIndex(src=src, handle.preserve="all")
name pos is.top is.bottom       class is.s4  dim
1                    a   1   TRUE     FALSE        list FALSE    5
2                a/a.1   2  FALSE      TRUE        list FALSE    3
3                a/a.2   2  FALSE      TRUE        list FALSE    3
4                a/a.3   2  FALSE      TRUE        list FALSE    3
5                a/a.4   2  FALSE      TRUE        list FALSE    3
6                a/a.5   2  FALSE      TRUE        list FALSE    3
7                    b   1   TRUE     FALSE        list FALSE    2
8                b/b.1   2  FALSE     FALSE        list FALSE    2
9          b/b.1/b.1.1   3  FALSE     FALSE        list FALSE    3
10 b/b.1/b.1.1/b.1.1.1   4  FALSE      TRUE      matrix FALSE  1-1
11 b/b.1/b.1.1/b.1.1.2   4  FALSE      TRUE      matrix FALSE  2-2
12 b/b.1/b.1.1/b.1.1.3   4  FALSE      TRUE      matrix FALSE  1-1
13         b/b.1/b.1.2   3  FALSE     FALSE        list FALSE    3
14 b/b.1/b.1.2/b.1.2.1   4  FALSE      TRUE  data.frame FALSE  1-1
15 b/b.1/b.1.2/b.1.2.2   4  FALSE      TRUE  data.frame FALSE  3-2
16 b/b.1/b.1.2/b.1.2.3   4  FALSE      TRUE  data.frame FALSE  0-0
17               b/b.2   2  FALSE     FALSE        list FALSE    1
18         b/b.2/b.2.1   3  FALSE     FALSE        list FALSE    4
19 b/b.2/b.2.1/b.2.1.1   4  FALSE      TRUE        list FALSE    1
20 b/b.2/b.2.1/b.2.1.2   4  FALSE      TRUE        list FALSE    2
21 b/b.2/b.2.1/b.2.1.3   4  FALSE      TRUE        list FALSE    5
22 b/b.2/b.2.1/b.2.1.4   4  FALSE     FALSE        list FALSE    0
23                   c   1   TRUE     FALSE        list FALSE    1
24               c/c.1   2  FALSE     FALSE        list FALSE    3
25         c/c.1/c.1.1   3  FALSE      TRUE environment FALSE
26         c/c.1/c.1.2   3  FALSE     FALSE TESTCLASS_X  TRUE    1
27         c/c.1/c.1.3   3  FALSE     FALSE TESTCLASS_Y  TRUE    1

> objectIndex(src=src, handle.preserve="data.frame")
name pos is.top is.bottom       class is.s4  dim
1                      a   1   TRUE     FALSE        list FALSE    5
2                  a/a.1   2  FALSE     FALSE        list FALSE    3
3            a/a.1/a.1.1   3  FALSE      TRUE     numeric FALSE    1
4            a/a.1/a.1.2   3  FALSE      TRUE     integer FALSE    5
5            a/a.1/a.1.3   3  FALSE      TRUE     integer FALSE    0
6                  a/a.2   2  FALSE     FALSE        list FALSE    3
7            a/a.2/a.2.1   3  FALSE      TRUE   character FALSE    1
8            a/a.2/a.2.2   3  FALSE      TRUE   character FALSE    5
9            a/a.2/a.2.3   3  FALSE      TRUE   character FALSE    0
10                 a/a.3   2  FALSE     FALSE        list FALSE    3
11           a/a.3/a.3.1   3  FALSE      TRUE     numeric FALSE    1
12           a/a.3/a.3.2   3  FALSE      TRUE     numeric FALSE    2
13           a/a.3/a.3.3   3  FALSE      TRUE     numeric FALSE    0
14                 a/a.4   2  FALSE     FALSE        list FALSE    3
15           a/a.4/a.4.1   3  FALSE      TRUE     complex FALSE    1
16           a/a.4/a.4.2   3  FALSE      TRUE     complex FALSE    3
17           a/a.4/a.4.3   3  FALSE      TRUE     complex FALSE    0
18                 a/a.5   2  FALSE     FALSE        list FALSE    3
19           a/a.5/a.5.1   3  FALSE      TRUE     logical FALSE    1
20           a/a.5/a.5.2   3  FALSE      TRUE     logical FALSE    3
21           a/a.5/a.5.3   3  FALSE      TRUE     logical FALSE    0
22                     b   1   TRUE     FALSE        list FALSE    2
23                 b/b.1   2  FALSE     FALSE        list FALSE    2
24           b/b.1/b.1.1   3  FALSE     FALSE        list FALSE    3
25   b/b.1/b.1.1/b.1.1.1   4  FALSE      TRUE      matrix FALSE  1-1
26   b/b.1/b.1.1/b.1.1.2   4  FALSE      TRUE      matrix FALSE  2-2
27   b/b.1/b.1.1/b.1.1.3   4  FALSE      TRUE      matrix FALSE  1-1
28           b/b.1/b.1.2   3  FALSE     FALSE        list FALSE    3
29   b/b.1/b.1.2/b.1.2.1   4  FALSE      TRUE  data.frame FALSE  1-1
30   b/b.1/b.1.2/b.1.2.2   4  FALSE      TRUE  data.frame FALSE  3-2
31   b/b.1/b.1.2/b.1.2.3   4  FALSE      TRUE  data.frame FALSE  0-0
32                 b/b.2   2  FALSE     FALSE        list FALSE    1
33           b/b.2/b.2.1   3  FALSE     FALSE        list FALSE    4
34   b/b.2/b.2.1/b.2.1.1   4  FALSE     FALSE        list FALSE    1
35 b/b.2/b.2.1/b.2.1.1/a   5  FALSE      TRUE     numeric FALSE    1
36   b/b.2/b.2.1/b.2.1.2   4  FALSE     FALSE        list FALSE    2
37 b/b.2/b.2.1/b.2.1.2/a   5  FALSE      TRUE     integer FALSE    2
38 b/b.2/b.2.1/b.2.1.2/b   5  FALSE      TRUE   character FALSE    2
39   b/b.2/b.2.1/b.2.1.3   4  FALSE     FALSE        list FALSE    5
40 b/b.2/b.2.1/b.2.1.3/a   5  FALSE      TRUE     integer FALSE    2
41 b/b.2/b.2.1/b.2.1.3/b   5  FALSE      TRUE   character FALSE    1
42 b/b.2/b.2.1/b.2.1.3/c   5  FALSE      TRUE     integer FALSE    3
43 b/b.2/b.2.1/b.2.1.3/d   5  FALSE      TRUE     logical FALSE    1
44 b/b.2/b.2.1/b.2.1.3/e   5  FALSE      TRUE     integer FALSE    5
45   b/b.2/b.2.1/b.2.1.4   4  FALSE     FALSE        list FALSE    0
46                     c   1   TRUE     FALSE        list FALSE    1
47                 c/c.1   2  FALSE     FALSE        list FALSE    3
48           c/c.1/c.1.1   3  FALSE      TRUE environment FALSE
49           c/c.1/c.1.2   3  FALSE     FALSE TESTCLASS_X  TRUE    1
50         c/c.1/c.1.2/a   5  FALSE      TRUE     integer FALSE    5
51           c/c.1/c.1.3   3  FALSE     FALSE TESTCLASS_Y  TRUE    1
52         c/c.1/c.1.3/a   4  FALSE      TRUE     integer FALSE    5

> objectIndex(src=src, handle.preserve="s4")
name pos is.top is.bottom       class is.s4  dim
1                       a   1   TRUE     FALSE        list FALSE    5
2                   a/a.1   2  FALSE     FALSE        list FALSE    3
3             a/a.1/a.1.1   3  FALSE      TRUE     numeric FALSE    1
4             a/a.1/a.1.2   3  FALSE      TRUE     integer FALSE    5
5             a/a.1/a.1.3   3  FALSE      TRUE     integer FALSE    0
6                   a/a.2   2  FALSE     FALSE        list FALSE    3
7             a/a.2/a.2.1   3  FALSE      TRUE   character FALSE    1
8             a/a.2/a.2.2   3  FALSE      TRUE   character FALSE    5
9             a/a.2/a.2.3   3  FALSE      TRUE   character FALSE    0
10                  a/a.3   2  FALSE     FALSE        list FALSE    3
11            a/a.3/a.3.1   3  FALSE      TRUE     numeric FALSE    1
12            a/a.3/a.3.2   3  FALSE      TRUE     numeric FALSE    2
13            a/a.3/a.3.3   3  FALSE      TRUE     numeric FALSE    0
14                  a/a.4   2  FALSE     FALSE        list FALSE    3
15            a/a.4/a.4.1   3  FALSE      TRUE     complex FALSE    1
16            a/a.4/a.4.2   3  FALSE      TRUE     complex FALSE    3
17            a/a.4/a.4.3   3  FALSE      TRUE     complex FALSE    0
18                  a/a.5   2  FALSE     FALSE        list FALSE    3
19            a/a.5/a.5.1   3  FALSE      TRUE     logical FALSE    1
20            a/a.5/a.5.2   3  FALSE      TRUE     logical FALSE    3
21            a/a.5/a.5.3   3  FALSE      TRUE     logical FALSE    0
22                      b   1   TRUE     FALSE        list FALSE    2
23                  b/b.1   2  FALSE     FALSE        list FALSE    2
24            b/b.1/b.1.1   3  FALSE     FALSE        list FALSE    3
25    b/b.1/b.1.1/b.1.1.1   4  FALSE      TRUE      matrix FALSE  1-1
26    b/b.1/b.1.1/b.1.1.2   4  FALSE      TRUE      matrix FALSE  2-2
27    b/b.1/b.1.1/b.1.1.3   4  FALSE      TRUE      matrix FALSE  1-1
28            b/b.1/b.1.2   3  FALSE     FALSE        list FALSE    3
29    b/b.1/b.1.2/b.1.2.1   4  FALSE      TRUE  data.frame FALSE  1-1
30 b/b.1/b.1.2/b.1.2.1/X1   5  FALSE      TRUE     numeric FALSE    1
31    b/b.1/b.1.2/b.1.2.2   4  FALSE      TRUE  data.frame FALSE  3-2
32  b/b.1/b.1.2/b.1.2.2/a   5  FALSE      TRUE     integer FALSE    3
33  b/b.1/b.1.2/b.1.2.2/b   5  FALSE      TRUE     integer FALSE    3
34    b/b.1/b.1.2/b.1.2.3   4  FALSE      TRUE  data.frame FALSE  0-0
35                  b/b.2   2  FALSE     FALSE        list FALSE    1
36            b/b.2/b.2.1   3  FALSE     FALSE        list FALSE    4
37    b/b.2/b.2.1/b.2.1.1   4  FALSE     FALSE        list FALSE    1
38  b/b.2/b.2.1/b.2.1.1/a   5  FALSE      TRUE     numeric FALSE    1
39    b/b.2/b.2.1/b.2.1.2   4  FALSE     FALSE        list FALSE    2
40  b/b.2/b.2.1/b.2.1.2/a   5  FALSE      TRUE     integer FALSE    2
41  b/b.2/b.2.1/b.2.1.2/b   5  FALSE      TRUE   character FALSE    2
42    b/b.2/b.2.1/b.2.1.3   4  FALSE     FALSE        list FALSE    5
43  b/b.2/b.2.1/b.2.1.3/a   5  FALSE      TRUE     integer FALSE    2
44  b/b.2/b.2.1/b.2.1.3/b   5  FALSE      TRUE   character FALSE    1
45  b/b.2/b.2.1/b.2.1.3/c   5  FALSE      TRUE     integer FALSE    3
46  b/b.2/b.2.1/b.2.1.3/d   5  FALSE      TRUE     logical FALSE    1
47  b/b.2/b.2.1/b.2.1.3/e   5  FALSE      TRUE     integer FALSE    5
48    b/b.2/b.2.1/b.2.1.4   4  FALSE     FALSE        list FALSE    0
49                      c   1   TRUE     FALSE        list FALSE    1
50                  c/c.1   2  FALSE     FALSE        list FALSE    3
51            c/c.1/c.1.1   3  FALSE      TRUE environment FALSE
52            c/c.1/c.1.2   3  FALSE      TRUE TESTCLASS_X  TRUE    1
53            c/c.1/c.1.3   3  FALSE      TRUE TESTCLASS_Y  TRUE    1

> objectIndex(src=src, handle.preserve=c("data.frame", "s4"))
name pos is.top is.bottom       class is.s4  dim
1                      a   1   TRUE     FALSE        list FALSE    5
2                  a/a.1   2  FALSE     FALSE        list FALSE    3
3            a/a.1/a.1.1   3  FALSE      TRUE     numeric FALSE    1
4            a/a.1/a.1.2   3  FALSE      TRUE     integer FALSE    5
5            a/a.1/a.1.3   3  FALSE      TRUE     integer FALSE    0
6                  a/a.2   2  FALSE     FALSE        list FALSE    3
7            a/a.2/a.2.1   3  FALSE      TRUE   character FALSE    1
8            a/a.2/a.2.2   3  FALSE      TRUE   character FALSE    5
9            a/a.2/a.2.3   3  FALSE      TRUE   character FALSE    0
10                 a/a.3   2  FALSE     FALSE        list FALSE    3
11           a/a.3/a.3.1   3  FALSE      TRUE     numeric FALSE    1
12           a/a.3/a.3.2   3  FALSE      TRUE     numeric FALSE    2
13           a/a.3/a.3.3   3  FALSE      TRUE     numeric FALSE    0
14                 a/a.4   2  FALSE     FALSE        list FALSE    3
15           a/a.4/a.4.1   3  FALSE      TRUE     complex FALSE    1
16           a/a.4/a.4.2   3  FALSE      TRUE     complex FALSE    3
17           a/a.4/a.4.3   3  FALSE      TRUE     complex FALSE    0
18                 a/a.5   2  FALSE     FALSE        list FALSE    3
19           a/a.5/a.5.1   3  FALSE      TRUE     logical FALSE    1
20           a/a.5/a.5.2   3  FALSE      TRUE     logical FALSE    3
21           a/a.5/a.5.3   3  FALSE      TRUE     logical FALSE    0
22                     b   1   TRUE     FALSE        list FALSE    2
23                 b/b.1   2  FALSE     FALSE        list FALSE    2
24           b/b.1/b.1.1   3  FALSE     FALSE        list FALSE    3
25   b/b.1/b.1.1/b.1.1.1   4  FALSE      TRUE      matrix FALSE  1-1
26   b/b.1/b.1.1/b.1.1.2   4  FALSE      TRUE      matrix FALSE  2-2
27   b/b.1/b.1.1/b.1.1.3   4  FALSE      TRUE      matrix FALSE  1-1
28           b/b.1/b.1.2   3  FALSE     FALSE        list FALSE    3
29   b/b.1/b.1.2/b.1.2.1   4  FALSE      TRUE  data.frame FALSE  1-1
30   b/b.1/b.1.2/b.1.2.2   4  FALSE      TRUE  data.frame FALSE  3-2
31   b/b.1/b.1.2/b.1.2.3   4  FALSE      TRUE  data.frame FALSE  0-0
32                 b/b.2   2  FALSE     FALSE        list FALSE    1
33           b/b.2/b.2.1   3  FALSE     FALSE        list FALSE    4
34   b/b.2/b.2.1/b.2.1.1   4  FALSE     FALSE        list FALSE    1
35 b/b.2/b.2.1/b.2.1.1/a   5  FALSE      TRUE     numeric FALSE    1
36   b/b.2/b.2.1/b.2.1.2   4  FALSE     FALSE        list FALSE    2
37 b/b.2/b.2.1/b.2.1.2/a   5  FALSE      TRUE     integer FALSE    2
38 b/b.2/b.2.1/b.2.1.2/b   5  FALSE      TRUE   character FALSE    2
39   b/b.2/b.2.1/b.2.1.3   4  FALSE     FALSE        list FALSE    5
40 b/b.2/b.2.1/b.2.1.3/a   5  FALSE      TRUE     integer FALSE    2
41 b/b.2/b.2.1/b.2.1.3/b   5  FALSE      TRUE   character FALSE    1
42 b/b.2/b.2.1/b.2.1.3/c   5  FALSE      TRUE     integer FALSE    3
43 b/b.2/b.2.1/b.2.1.3/d   5  FALSE      TRUE     logical FALSE    1
44 b/b.2/b.2.1/b.2.1.3/e   5  FALSE      TRUE     integer FALSE    5
45   b/b.2/b.2.1/b.2.1.4   4  FALSE     FALSE        list FALSE    0
46                     c   1   TRUE     FALSE        list FALSE    1
47                 c/c.1   2  FALSE     FALSE        list FALSE    3
48           c/c.1/c.1.1   3  FALSE      TRUE environment FALSE
49           c/c.1/c.1.2   3  FALSE      TRUE TESTCLASS_X  TRUE    1
50           c/c.1/c.1.3   3  FALSE      TRUE TESTCLASS_Y  TRUE    1

Benchmarking

> require(microbenchmark)
> res <- microbenchmark(objectIndex(src=src))
median(res$time/1000000000)
> [1] 0.3378009

Here’s the code:

Generics

setGeneric(
name="argProcess",
signature=c("arg"),
def=function(
arg,
...
){
standardGeneric("argProcess")
}
)

setGeneric(
name="gregexpr2",
signature=c("src"),
def=function(
src,
...
){
standardGeneric("gregexpr2")
}
)

setGeneric(
name="objectIndex",
signature=c("src"),
def=function(
src,
...
){
standardGeneric("objectIndex")
}
)

Methods

setMethod(
f="argProcess",
signature=signature(arg="character"),
definition=function(
arg,
value.valid=NULL,
idx.restrict=NULL,
do.remove.null=FALSE,
...
){

#---------------------------------------------------------------------------
# ACTUAL PROCESSING
#---------------------------------------------------------------------------

if(!is.null(value.valid)){
subsetValidate(src=arg, tgt=value.valid,
.ARGS=.ARGS)
}

out <- arg
#    if(length(arg) > 1){
#        out <- arg[1]
#    }
if(!is.null(idx.restrict)){
if(!is.numeric(idx.restrict)){
stop(paste("/invalid restriction index", sep=""))
}
if(length(idx.restrict) > length(out)){
stop(paste("/invalid restriction index length", sep=""))
}
if(idx.restrict == 0){
if(length(out) > 1){
msg <- c(
paste("/invalid argument value", sep=""), "\n",
paste("* Value: '", paste(out, collapse=", "), "'", sep=""), "\n",
paste("* Needs to be singular", sep="")
)
stop(msg)
}
} else {
out <- out[idx.restrict]
}
}

# REMOVE NULL
if(do.remove.null){
idx.null <- which(is.null(out))
if(length(idx.null)){
out <- out[-idx.null]
}
}
# /

# /ACTUAL PROCESSING ----------

#---------------------------------------------------------------------------
# FINALIZE
#---------------------------------------------------------------------------

return(out)

# /FINALIZE ----------

}
)

setMethod(
f="gregexpr2",
signature=signature(src="character"),
definition=function(
src,
pattern,
do.ignore.case=FALSE,
do.perl=TRUE,
do.fixed=FALSE,
do.useBytes=FALSE,
do.simplify=FALSE,
...
){

#---------------------------------------------------------------------------
# ACTUAL PROCESSING
#---------------------------------------------------------------------------

if(all(is.na(src))){
out <- lapply(1:length(src), function(x){
out <- data.frame(start=NA, stop=NA)
})
} else {
idx.regex <- gregexpr(
text=src,
pattern=pattern,
ignore.case=do.ignore.case,
perl=do.perl,
fixed=do.fixed,
useBytes=do.useBytes
)
out <- lapply(idx.regex, function(x){
if(any(x == -1)){
out <- data.frame(start=NA, stop=NA)
} else {
out <- data.frame(start=x, stop=x+(attributes(x)$match.length-1))
}
return(out)
})
}

if(do.simplify){
if(length(out) == 1){
out <- out[[1]]
}
}

# /ACTUAL PROCESSING ----------

#---------------------------------------------------------------------------
# FINALIZE
#---------------------------------------------------------------------------

return(out)

# /FINALIZE ----------

}
)

setMethod(
f="objectIndex",
signature=signature(src="list"),
definition=function(
src,
handle.preserve=c("standard", "all", "no", "data.frame", "s4"),
.delim.path="/",
...
){

#---------------------------------------------------------------------------
# GENERAL PREPROCESSING
#---------------------------------------------------------------------------

handle.preserve <- argProcess(
arg=handle.preserve,
value.valid=c("standard", "all", "no", "data.frame", "s4")
)
if("standard" %in% handle.preserve){
handle.preserve <- "standard"
}

# /GENERAL PREPROCESSING ----------

#---------------------------------------------------------------------------
# PREPROCESSING
#---------------------------------------------------------------------------

# TRANSFORM IF FLAT
if(all(length(grep(.delim.path, names(src))>0))){
# This is assuming that src is already an flattened list.
cat(paste("/preprocessing 'src' (deepening) ...", sep=""), sep="\n")
src <- objectDeepen(src=src, .ARGS=.ARGS)
}
# /

pattern <- "(\\.\\.)"

# RETRIEVE STRUCTURE
temp <- capture.output(str(src))
temp <- temp[-1]
# /

# DROP ATTRIBUTES
idx <- grep("\\.- attr\\(", temp)
idx.drop <- unlist(lapply(idx, function(x.idx){
temp.attr <- temp[x.idx]
idx.1 <- gregexpr2(
src=temp.attr,
pattern="(\\[.*\\])|([[:digit:]]+\\s*obs|of|with).*[[:digit:]]+",
do.simplify=TRUE
)
out <- NULL
if(all(!is.na(unlist(idx.1)))){
out <- as.numeric(
gsub("[[:alpha:]]|[[:punct:]]|\\s", "", substr(temp.attr, start=idx.1$start, stop=idx.1$stop))
)
out <- x.idx:(x.idx+out)
}
}))
if(length(idx.drop)){
temp <- temp[-idx.drop]
}
#temp
# /

# DROP METHODS
idx.drop <- grep("\\..*[[:digit:]]+\\s*methods", temp)
if(length(idx.drop)){
temp <- temp[-idx.drop]
}
#temp
# /

# /PREPROCESSING ----------

#---------------------------------------------------------------------------
# CLASS + DIMENSION
#---------------------------------------------------------------------------

# GET INDEX
idx <- gregexpr2(
src=temp,
pattern=":.*$"
)
# /

# CLASS AND DIM INFO
class.info <- lapply(seq(along=idx), function(x.idx){
out.0 <- substr(temp[x.idx], start=idx[[x.idx]]$start, stop=idx[[x.idx]]$stop)
if(is.na(out.0)){
return(NULL)
}
# DIMENSION / LENGTH
out.dim <- 1
# Check for zero length
idx.1 <- gregexpr2(
src=out.0,
pattern="^:\\s*\\w+\\(.*\\)",
do.simplify=TRUE
)
if(!all(is.na(unlist(idx.1)))){
out.dim <- 0
idx.1   <- NA
} else {
# Check for non-zero length
idx.1 <- gregexpr2(
src=out.0,
#                    pattern="\\[[.*\\]]",
pattern="(\\[\\d+,?.*\\])|(:\t[[:digit:]]|(of|with).*[[:digit:]]+)",
do.simplify=TRUE
)
}
#print(idx.1)
#        out.dim <- NA
if(all(!is.na(unlist(idx.1)))){
#x.idx=1
out.dim <- lapply(1:nrow(idx.1), function(x.idx){
out.dim <- substr(out.0, start=idx.1$start[x.idx],
stop=idx.1$stop[x.idx])
out.dim <- unlist(strsplit(out.dim, split=", "))
out.dim <- lapply(out.dim, function(x.dim){
out.dim <- x.dim
idx.1 <- gregexpr2(
src=out.dim,
pattern="[[:digit:]]+",
do.simplify=TRUE
)
out.dim <- sapply(1:nrow(idx.1), function(x.row){
substr(out.dim, start=idx.1$start[x.row], stop=idx.1$stop[x.row])
})
})
if(length(out.dim) == 1){
out.dim <- out.dim[[1]]
}
out.dim
})
}
#print(out.dim)
# /
# CLASS
idx.s4 <- FALSE

idx.1 <- gregexpr2(
src=out.0,
pattern="^:\\s*<?\\w+:?|('.*')",
do.simplify=TRUE
)
out.class <- NA
if(all(!is.na(idx.1$start))){
out.class <- sapply(1:nrow(idx.1), function(x.row){
out <- substr(out.0, start=idx.1$start[x.row], stop=idx.1$stop[x.row])
out <- gsub("^[[:punct:]]*|[[:punct:]]*$|\\s*", "", out)
})
}
if(class(out.dim[[1]]) == "list" & any(out.class != "data.frame")){
out.class <- "matrix"
} else {
out.dim <- unlist(out.dim)
}

out.class <- switch(
out.class[1],
"chr"="character",
"cplx"="complex",
"data.frame"={
out.dim <- paste(out.dim, collapse="-")
"data.frame"
},
"environment"={
out.dim <- NA
"environment"
},
"Formal"={
idx.s4 <- TRUE
out.class[2]
},
"int"="integer",
"list"="list",
"List"="list",
"logi"="logical",
"matrix"={
out.dim <- sapply(out.dim[[1]], function(x){
out.dim <- x
if(length(out.dim) > 1){
out.dim <- out.dim[2]
}
out.dim
})
out.dim <- paste(out.dim, collapse="-")
"matrix"
},
"num"="numeric",
"Reference"={
idx.s4 <- TRUE
out.class[2]
}
)
# /
if(length(out.dim) > 1){
out.dim <- out.dim[2]
}
out <- data.frame(class=out.class, is.s4=idx.s4,
dim=out.dim, stringsAsFactors=FALSE)
return(out)
})
class.info <- do.call("rbind", class.info)
# /

idx.na <- which(is.na(class.info$class))
if(length(idx.na)){
class.info <- class.info[-idx.na,]
}

# /CLASS + DIMENSION ----------

#---------------------------------------------------------------------------
# MAIN PROCESSING
#---------------------------------------------------------------------------

temp <- gsub(":.*$", "", temp)
temp <- gsub("\\s*\\$\\s*", "", temp)
temp <- gsub("^\\s*", "", temp)
temp <- gsub("@", "", temp)
struc.names <- gsub("\\s*$", "", temp)
#struc.names
# /

# TRANSFORM STRUCTURE
idx.regex <- gregexpr2(
src=struc.names,
pattern=pattern
)
struc.names <- gsub(paste(pattern, "|\\s*", sep=""), "", struc.names)
struc.pos   <- sapply(idx.regex, function(x){
out <- 0
if(all(!is.na(x$start))){
out <- nrow(x)
}
return(out)
})

# STOP ON EMPTY NAMES
idx.empty <- which(struc.names == "")
if(length(idx.empty)){
msg <- c(
paste("/names error:", sep=""), "\n",
paste("* Names: {", paste(struc.names, collapse=", "), "}", sep="")
)
stop(msg)
}
# /

# STRUCTURE
pos         <- -1
path.0      <- NULL
path.1      <- NULL
is.top      <- NULL
idx.zero <- which(struc.pos == 0)
for(x in 1:length(struc.pos)){
res         <- struc.pos[x]
pos.new     <- list(res)
path.0.new  <- struc.names[x]
if(struc.pos[x] > pos){
pos <- struc.pos[x]
} else {
# RESET
if(struc.pos[x] < pos){
pos <- struc.pos[x]
}
if(pos == 0){
path.0 <- NULL
} else {
path.0 <- path.0[1:pos]
}
# /
pos.new <- list(0:res)

}
path.0  <- c(path.0, path.0.new)

path.1.new  <- paste(path.0, collapse=.delim.path)
path.1  <- c(path.1, path.1.new)

is.top.new  <- length(path.0) == 1
is.top      <- c(is.top, is.top.new)
}

# STRUCTURE DF
struc.df <- data.frame(
name=path.1,
pos=struc.pos+1,
is.top=is.top,
is.bottom=FALSE,
class.info,
stringsAsFactors=FALSE
)
# /

# BOTTOM BRANCHES
classes.pres <- "list"
idx.bottom <- which(!(struc.df$class %in% classes.pres) & !struc.df$is.s4)
if(length(idx.bottom)){
struc.df$is.bottom[idx.bottom] <- TRUE
}
# /

# HANDLE PRESERVE
if(!("no" %in% handle.preserve)){
if(any(c("standard", "data.frame") %in% handle.preserve)){
idx.pres <- which(struc.df$class == "data.frame")
if(length(idx.pres)){
struc.df$is.bottom[idx.pres] <- TRUE
obj.dim <- sapply(strsplit(struc.df$dim[idx.pres], split="-"), function(x){
as.numeric(x[2])
})
idx.drop    <- which(obj.dim == 0)
if(length(idx.drop)){
obj.dim     <- obj.dim[-idx.drop]
idx.pres    <- idx.pres[-idx.drop]
}
idx.temp    <- data.frame(start=idx.pres+1, stop=idx.pres+obj.dim)
idx.drop    <- unlist(lapply(1:nrow(idx.temp), function(x.row){
idx.temp$start[x.row]:idx.temp$stop[x.row]
}))
if(length(idx.drop)){
struc.df <- struc.df[-idx.drop,]
rownames(struc.df) <- NULL
}
}
}
if(any(c("standard", "s4") %in% handle.preserve)){
idx.pres <- which(struc.df$is.s4)
if(length(idx.pres)){
struc.df$is.bottom[idx.pres] <- TRUE
obj.dim     <- as.numeric(struc.df$dim[idx.pres])
idx.temp    <- data.frame(start=idx.pres+1, stop=idx.pres+obj.dim)
idx.drop    <- unlist(lapply(1:nrow(idx.temp), function(x.row){
idx.temp$start[x.row]:idx.temp$stop[x.row]
}))
idx.keep    <- which(idx.drop %in% idx.pres)
if(length(idx.keep)){
idx.drop <- idx.drop[-idx.keep]
}
if(length(idx.drop)){
struc.df <- struc.df[-idx.drop,]
rownames(struc.df) <- NULL
}
}
}
if(any("all" %in% handle.preserve)){
idx.pres <- which(struc.df$class == "list")
if(length(idx.pres)){
classes.pres <- c("data.frame", "environment", "list", "matrix")
idx.drop <- which(
struc.df$is.bottom &
!(struc.df$class %in% classes.pres) &
!(struc.df$is.s4)
)
idx.change <- idx.pres + 1
idx <- which(idx.change %in% idx.drop)
if(length(idx)){
idx.change <- idx.change[idx] - 1
}
struc.df$is.bottom[idx.change] <- TRUE
if(length(idx.drop)){
struc.df <- struc.df[-idx.drop,]
rownames(struc.df) <- NULL
}
}
}
}
# /

out <- struc.df

# /MAIN PROCESSING ----------

#---------------------------------------------------------------------------
# FINALIZE
#---------------------------------------------------------------------------

return(out)

# /FINALIZE ----------

}
)

subsetValidate <- function(
src,
tgt,
do.index=FALSE,
index.type=c("logical", "numeric", "logical.all", "logical.any"),
do.strict=TRUE,
do.warning=TRUE,
do.allow.nomatch=FALSE,
value.nomatch=NULL,
...
){
#---------------------------------------------------------------------------
# GENERAL PREPROCESSING
#---------------------------------------------------------------------------

if(missing(src) | missing(tgt)){
stop("/missing arguments 'src' and/or 'tgt'", sep="")
}
# VALIDATING AND PROCESSING SOURCE AND TARGET
do.special.src <- FALSE
if(!is.character(src)){
if(.do.verbose | .do.debug){
cat(paste("/non-character 'src'. Processing ...",
sep=""), sep="\n")
}
if(!is.na(src)){
if(is.null(names(src))){
stop(paste("/'src' has no names. Processing failed.",
sep=""), sep="\n")
}
}
do.special.src <- TRUE
src.0   <- src
src     <- names(src)
}
do.special.tgt <- FALSE
if(!is.character(tgt)){
if(.do.verbose | .do.debug){
cat(paste("/non-character 'tgt'. Processing ...",
sep=""), sep="\n")
}
if(!is.na(tgt)){
if(is.null(names(tgt))){
stop(paste("/'tgt' has no names. Processing failed.",
sep=""), sep="\n")
}
}
do.special.tgt <- TRUE
tgt.0   <- tgt
tgt     <- names(tgt)
}
# /
#    if(!is.character(src) | !is.character(tgt)){
#        stop(paste(
#            "/expecting args 'src' and 'tgt' to be of class 'character'",
#            sep=""))
#    }
index.type.valid <- c("logical", "numeric", "logical.all", "logical.any")
if(!all(index.type %in% index.type.valid)){
msg <- c(
paste("/arg 'index.type' is invalid:", sep=""),
"\n",
paste("* Value: ", paste(deparse(index.type), collapse=""), sep=""),
"\n",
paste("* Valid: ", paste(deparse(index.type.valid), collapse=""), sep="")
)
stop(msg)
}
if(do.index & length(index.type) > 1){
index.type <- index.type[1]
}

# /GENERAL PREPROCESSING ----------

#---------------------------------------------------------------------------
# ACTUAL PROCESSING
#---------------------------------------------------------------------------

idx.0 <- src %in% tgt
idx.1 <- which(idx.0)

if(do.index){
if(.do.verbose | .do.debug){
cat(paste("/swiching arg 'do.strict = FALSE", sep=""), sep="\n")
cat(paste("/swiching arg 'do.warning = FALSE", sep=""), sep="\n")
}
do.strict   <- FALSE
do.warning  <- FALSE
if(index.type == "logical"){
out.idx <- idx.0
names(out.idx) <- src
}
if(index.type == "numeric"){
out.idx <- idx.1
names(out.idx) <- src[out.idx]
}
if(index.type == "logical.all"){
out.idx <- all(idx.0)
}
if(index.type == "logical.any"){
out.idx <- any(idx.0)
}
}

# NO MATCH
if(!length(idx.1)){
if(!do.index){
if(do.allow.nomatch){
# LOCAL TERMINATE

return(value.nomatch)
} else {
msg <- c(
paste("/non-matching elements in 'src' (all):", sep=""),
"\n",
paste("* '", src, "'", sep="")
)
stop(msg)
}
} else {
if(index.type == "numeric"){
out.idx <- numeric(0)
}
return(any(idx.0))
}
}
# /
# PARTLY MATCH
if(!all(idx.0)){
msg <- c(
paste("/partly non-matching elements in 'src':", sep=""),
"\n",
paste("* '", src[which(!idx.0)], "'", sep="")
)
if(do.strict){
if(do.allow.nomatch){
# LOCAL TERMINATE

return(value.nomatch)
} else {
stop(msg)
}
} else {
if(do.warning){
warning(msg)
}
}
}
# /
if(!do.index){
if(do.special.src){
if(is.data.frame(src.0) | is.matrix(src.0)){
tgt <- src.0[,idx.1]
} else {
tgt <- src.0[idx.1]
}
} else {
tgt <- src[idx.1]
}
out <- tgt
} else {
out <- out.idx
}
# /

#---------------------------------------------------------------------------
# FINALIZE
#---------------------------------------------------------------------------

return(out)

# /FINALIZE ----------
}

- at least if you’re sitting in front of a German Windows-Box

This is what I used to do to set my tz:

options(tz="Europe/Berlin")

And I always wondered why R would throw “unknown timezone” warnings:

> t <- "2011-11-08 09:42:00"
 > as.POSIXct(t, tz=getOption("tz"))
 [1] "2011-11-08 09:42:00 CET"
 Warning messages:
 1: In strptime(xx, f <- "%Y-%m-%d %H:%M:%OS", tz = tz) :
 unknown timezone 'MET-1MST'
 2: In as.POSIXct.POSIXlt(x) : unknown timezone 'MET-1MST'
 3: In strptime(x, f, tz = tz) : unknown timezone 'MET-1MST'
 4: In as.POSIXct.POSIXlt(as.POSIXlt(x, tz, ...), tz, ...) :
 unknown timezone 'MET-1MST'
 5: In as.POSIXlt.POSIXct(x, tz) : unknown timezone 'MET-1MST'

Someday I found out that setting tz via `options()` was not enough as the environment variable `TZ` is not affected and hence all the the trouble:

> Sys.getenv("TZ")
 [1] "MET-1MST"

Changing this should do away with the nasty warnings:

> Sys.setenv(TZ="Europe/Berlin")
 > Sys.getenv("TZ")
 [1] "Europe/Berlin"
 > as.POSIXct(t, tz=getOption("tz"))
 [1] "2011-11-08 09:42:00 CET"

http://stackoverflow.com/questions/7728462/identify-records-in-data-frame-a-not-contained-in-data-frame-b

I had collected 9 different solutions to the problem and made the mistake to put it all within the original question space. So people complained and told me that such a collection belongs into a blog and not on Stackoverflow. Hence, I decided to go ahead and finally make my first blogging steps! I’ll probably still miss out on a lot of cool technical stuff on the blog, so please bear with me.

So here’s the thing:

Problem

How to identify records/rows in data frame x.1 that are not contained in data frame x.2 based on all attributes available (i.e. all columns) in the most efficient way?

Example Data

> x.1 <- data.frame(a=c(1,2,3,4,5), b=c(1,2,3,4,5))
> x.1
a b
1 1 1
2 2 2
3 3 3
4 4 4
5 5 5

> x.2 <- data.frame(a=c(1,1,2,3,4), b=c(1,1,99,3,4))
> x.2
a  b
1 1  1
2 1  1
3 2 99
4 3  3
5 4  4

# BENCHMARK SETTINGS
require(microbenchmark)
to.sec <- 1000000000

Desired Result

  a b
2 2 2
5 5 5

Best Solution So Far

by Prof. Brian Ripley and Gabor Grothendieck

> fun.12 <- function(x.1,x.2,...){
+     x.1p <- do.call("paste", x.1)
+     x.2p <- do.call("paste", x.2)
+     x.1[! x.1p %in% x.2p, ]
+ }
> fun.12(x.1,x.2)
  a b
2 2 2
5 5 5
> sol.12 <- microbenchmark(fun.12(x.1,x.2))
> sol.12 <- median(sol.12$time)/to.sec
> sol.12
> [1] 0.0002059665

Efficiency Comparison

> sol.scope <- 1:13
> comp <- data.frame(lapply(sol.scope, function(x){
+     eval(substitute(get(SOL), list(SOL=paste("sol.", x, sep=""))))
+ }))
> names(comp) <- paste("solution", sol.scope)
> comp <- as.data.frame(t(comp[order(comp[1,])]))
> colnames(comp) <- "time"
> comp
time   time.rel
solution 12 0.0002080150   1.000000
solution 3  0.0002548310   1.225061
solution 1  0.0004656785   2.238677
solution 10 0.0006398950   3.076196
solution 6  0.0007878430   3.787434
solution 8  0.0010459795   5.028385
solution 11 0.0021617355  10.392210
solution 9  0.0025755710  12.381660
solution 7  0.0103444610  49.729399
solution 13 0.0211265200 101.562483
solution 5  0.0225685395 108.494770
solution 2            NA         NA
solution 4            NA         NA

Here are all the solutions I collected so far:

Solution 1

by Chase

> fun.1 <- function(x.1,x.2,...){
+     expr <- paste("subset(x.1,", paste(sapply(names(x.1), function(x){
+         paste("!(", x, " %in% x.2$", x, ")", sep="")
+     }), collapse=" | "), ")")
+     eval(parse(text=expr))
+ }
> fun.1(x.1,x.2)
a b
2 2 2
5 5 5
> sol.1 <- microbenchmark(fun.1(x.1,x.2))
> sol.1 <- median(sol.1$time)/to.sec
> sol.1
[1] 0.0004656785

Solution 2 (rather just an approach)

by Ramnath

> setdiff(x.1$a, x.2$a)   # elements in x.1$a NOT in x.2$a
[1] 5
> setdiff(x.2$a, x.1$a)   # elements in x.2$a NOT in x.1$a
numeric(0)
> sol.2 <- microbenchmark(setdiff(x.1$a, x.2$a))
> sol.2 <- median(sol.2$time)/to.sec
> sol.2
[1] 4.03865e-05
# This helps, but as it does not directly provide the solution, we will set this to 'NA'
sol.2 <- NA

Solution 3

by Prof. Brian Ripley

> fun.3 <- function(x.1, x.2, ...){
+     x.1.id <- do.call("paste", c(x.1, sep = "\r"))
+     x.2.id <- do.call("paste", c(x.2, sep = "\r"))
+     x.1[match(setdiff(x.1.id, x.2.id),x.1.id), ]
+ }
> fun.3(x.1,x.2)
a b
1 2 2
2 5 5
> sol.3 <- microbenchmark(fun.3(x.1,x.2))
> sol.3 <- median(sol.3$time)/to.sec
> sol.3
[1] 0.000254831

Solution 4 (rather just an approach)

by me

> fun.4 <- function(x.1, x.2, ...){
+     # Combine
+     df <- rbind(x.1,x.2)
+     df <- df[order(df[,1]),]
+     # Find duplicates
+     idx.1 <- duplicated(df, all=TRUE)
+     idx.2 <- duplicated(df, fromLast=TRUE)
+     idx <- cbind(idx.1, idx.2)
+     idx <- apply(idx, MARGIN=1, any)
+     # Index records
+     df[-which(idx),]
+ }
> fun.4(x.1,x.2)
a b
1 2 2
8 2 99
2 5 5
> sol.4 <- microbenchmark(fun.4(x.1,x.2))
> sol.4 <- median(sol.4$time)/to.sec
> sol.4
[1] 0.001062621
# As it does not match the desired records, we set this to 'NA'
sol.4 <- NA

Solution 5

base on solution by Gabor Grothendieck

> library(sqldf)
> fun.5 <- function(x1,x2,...){
+     out <- sqldf(
+         "SELECT * FROM x1
+             WHERE
+                 x1.a NOT IN (SELECT x2.a FROM x2) OR
+                 x1.b NOT IN (SELECT x2.b FROM x2)"
+     )
+     out
+ }
> fun.5(x1=x.1,x2=x.2)
a b
1 2 2
2 5 5
> sol.5 <- microbenchmark(fun.5(x1=x.1,x2=x.2))
> sol.5 <- median(sol.5$time)/to.sec
> sol.5
[1] 0.02256854

Solution 6

by Tal Galili

> fun.6 <- function(x.1,x.2){
+     x.1.vec <- apply(x.1, 1, paste, collapse = "")
+     x.2.vec <- apply(x.2, 1, paste, collapse = "")
+     x.1.without.x.2.rows <- x.1[!x.1.vec %in% x.2.vec,]
+     return(x.1.without.x.2.rows)
+ }
> fun.6(x.1,x.2)
a b
1 2 2
2 5 5
> sol.6 <- microbenchmark(fun.6(x.1,x.2))
> sol.6 <- median(sol.6$time)/to.sec
> sol.6
[1] 0.000787843

Solution 7

by nullglob

# COULD NOT REPRODUCE RESULTS WITH MY DATA
> fun.7 <- function(x.1,x.2,...){
+     a1 <- data.frame(a = 1:5, b = letters[1:5])
+     a2 <- data.frame(a = 1:3, b = letters[1:3])
+     comparison <- compare(a1,a2,allowAll=TRUE)
+     comparison$tM
+     difference <-
+         data.frame(lapply(1:ncol(a1),function(i)setdiff(a1[,i],comparison$tM[,i])))
+     colnames(difference) <- colnames(a1)
+     difference
+ }
> fun.7(x.1,x.2)
  a b
1 4 d
2 5 e
> ### DISCUSSION ###
> # 1) Effectiveness
> # Could not reproduce results with my data frames.
> # 2) Efficiency
> sol.7 <- microbenchmark(fun.7(x.1,x.2))
> sol.7 <- median(sol.7$time)/to.sec
> sol.7
[1] 0.01034446

Solution 8

by Henrico

#  Derived from src/library/base/R/merge.R
#  Part of the R package, http://www.R-project.org
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  http://www.r-project.org/Licenses/
> XinY <-
+     function(x, y, by = intersect(names(x), names(y)), by.x = by, by.y = by,
+              notin = FALSE, incomparables = NULL,
+              ...)
+ {
+     fix.by <- function(by, df)
+     {
+         ## fix up 'by' to be a valid set of cols by number: 0 is row.names
+         if(is.null(by)) by <- numeric(0L)
+         by <- as.vector(by)
+         nc <- ncol(df)
+         if(is.character(by))
+             by <- match(by, c("row.names", names(df))) - 1L
+         else if(is.numeric(by)) {
+             if(any(by < 0L) || any(by > nc))
+                 stop("'by' must match numbers of columns")
+         } else if(is.logical(by)) {
+             if(length(by) != nc) stop("'by' must match number of columns")
+             by <- seq_along(by)[by]
+         } else stop("'by' must specify column(s) as numbers, names or logical")
+         if(any(is.na(by))) stop("'by' must specify valid column(s)")
+         unique(by)
+     }
+     nx <- nrow(x <- as.data.frame(x)); ny <- nrow(y <- as.data.frame(y))
+     by.x <- fix.by(by.x, x)
+     by.y <- fix.by(by.y, y)
+     if((l.b <- length(by.x)) != length(by.y))
+         stop("'by.x' and 'by.y' specify different numbers of columns")
+     if(l.b == 0L) {
+         ## was: stop("no columns to match on")
+         ## returns x
+         x
+     }
+     else {
+         if(any(by.x == 0L)) {
+             x <- cbind(Row.names = I(row.names(x)), x)
+             by.x <- by.x + 1L
+         }
+         if(any(by.y == 0L)) {
+             y <- cbind(Row.names = I(row.names(y)), y)
+             by.y <- by.y + 1L
+         }
+         ## create keys from 'by' columns:
+         if(l.b == 1L) {                  # (be faster)
+             bx <- x[, by.x]; if(is.factor(bx)) bx <- as.character(bx)
+             by <- y[, by.y]; if(is.factor(by)) by <- as.character(by)
+         } else {
+             ## Do these together for consistency in as.character.
+             ## Use same set of names.
+             bx <- x[, by.x, drop=FALSE]; by <- y[, by.y, drop=FALSE]
+             names(bx) <- names(by) <- paste("V", seq_len(ncol(bx)), sep="")
+             bz <- do.call("paste", c(rbind(bx, by), sep = "\r"))
+             bx <- bz[seq_len(nx)]
+             by <- bz[nx + seq_len(ny)]
+         }
+         comm <- match(bx, by, 0L)
+         if (notin) {
+             res <- x[comm == 0,]
+         } else {
+             res <- x[comm > 0,]
+         }
+     }
+     ## avoid a copy
+     ## row.names(res) <- NULL
+     attr(res, "row.names") <- .set_row_names(nrow(res))
+     res
+ }
> XnotinY <-
+     function(x, y, by = intersect(names(x), names(y)), by.x = by, by.y = by,
+              notin = TRUE, incomparables = NULL,
+              ...)
+ {
+     XinY(x,y,by,by.x,by.y,notin,incomparables)
+ }
> fun.8 <- XnotinY
> fun.8(x.1,x.2)
a b
1 2 2
2 5 5
> sol.8 <- microbenchmark(fun.8(x.1,x.2))
> sol.8 <- median(sol.8$time)/to.sec
> sol.8
[1] 0.00104598

Solution 9

by Tomas T.

> fun.9 <- function(x.1,x.2,...){
+     tmp = merge(x.1, cbind(x.2, q=1:nrow(x.2)), all.x = TRUE)
+         # provided that there's no column q in both dataframes
+     tmp[is.na(tmp$q), 1:ncol(x.1)] # the result
+ }
> fun.9(x.1,x.2)
a b
1 2 2
2 5 5
> sol.9 <- microbenchmark(fun.9(x.1,x.2))
> sol.9 <- median(sol.9$time)/to.sec
> sol.9
[1] 0.002575571

Solution 10

by Gabor Grothendieck

> fun.10 <- function(x.1,x.2,...){
+     x.1[!duplicated(rbind(x.2, x.1))[-(1:nrow(x.2))],]
+ }
> fun.10(x.1,x.2)
a b
1 2 2
2 5 5
> sol.10 <- microbenchmark(fun.10(x.1,x.2))
> sol.10 <- median(sol.10$time)/to.sec
> sol.10
[1] 0.000639895

Solution 11

by Gabor Grothendieck

> fun.11 <- function(x.1,x.2,...){
+     do.call("rbind", setdiff(split(x.1, rownames(x.1)), split(x.2, rownames(x.2))))
+ }
> fun.11(x.1,x.2)
a b
1 2 2
2 5 5
> sol.11 <- microbenchmark(fun.11(x.1,x.2))
> sol.11 <- median(sol.11$time)/to.sec
> sol.11
[1] 0.002161735

Solution 12

by Gabor Grothendieck

> fun.12 <- function(x.1,x.2,...){
+     x.1p <- do.call("paste", x.1)
+     x.2p <- do.call("paste", x.2)
+     x.1[! x.1p %in% x.2p, ]
+ }
> fun.12(x.1,x.2)
a b
1 2 2
2 5 5
> sol.12 <- microbenchmark(fun.12(x.1,x.2))
> sol.12 <- median(sol.12$time)/to.sec
> sol.12
[1] 0.000208015

Solution 13

by Gabor Grothendieck

> library(sqldf)
> fun.13 <- function(x.1,x.2,...){
+     sqldf("select * from `x.1` except select * from `x.2`")
+ }
> fun.13(x.1,x.2)
a b
1 2 2
2 5 5
> sol.13 <- microbenchmark(fun.13(x.1,x.2))
> sol.13 <- median(sol.13$time)/to.sec
> sol.13
[1] 0.02112652

I decided to start blogging a bit to throw my weird R code examples at you ;-)

Hope you’ll like it!

Greetz,

Janko