How do I read/write libsvm data into/from R?
The libsvm format is sparse data like
<class/target>[ <attribute number>:<attribute value>]*
(cf. Compressed Row Storage (CRS)) e.g.,
1 10:3.4 123:0.5 34567:0.231
0.2 22:1 456:03
I am sure I can whip some something myself, but I would much rather use something off the shelf. However, R library foreign does not seem to provide the necessary functionality.
e1071 is off the shelf:install.packages("e1071")
library(e1071)
read.matrix.csr(...)
write.matrix.csr(...)
Note: it is implemented in R, not in C, so it is dog-slow.
It even have a special vignette Support Vector Machines—the Interface to libsvm in package e1071.
r.vw is bundled with vowpal_wabbitNote: it is implemented in R, not in C, so it is dog-slow.
I have been running a job using the zygmuntz solution on a dataset with 25k observations (rows) for almost 5 hrs now. It has done 3k-ish rows. It was taking so long that I coded this up in the meantime (based on zygmuntz's code):
require(Matrix)
read.libsvm = function( filename ) {
content = readLines( filename )
num_lines = length( content )
tomakemat = cbind(1:num_lines, -1, substr(content,1,1))
# loop over lines
makemat = rbind(tomakemat,
do.call(rbind,
lapply(1:num_lines, function(i){
# split by spaces, remove lines
line = as.vector( strsplit( content[i], ' ' )[[1]])
cbind(i, t(simplify2array(strsplit(line[-1],
':'))))
})))
class(makemat) = "numeric"
#browser()
yx = sparseMatrix(i = makemat[,1],
j = makemat[,2]+2,
x = makemat[,3])
return( yx )
}
This ran in minutes on the same machine (there may have been memory issues with zygmuntz solution too, not sure). Hope this helps anyone with the same problem.
Remember, if you need to do big computations in R, VECTORIZE!
EDIT: fixed an indexing error I found this morning.
I came up with my own ad hoc solution leveraging some data.table utilities,
It ran in almost no time on the test data set I found (Boston Housing data).
Converting that to a data.table (orthogonal to solution, but adding here for easy reproducibility):
library(data.table)
x = fread("/media/data_drive/housing.data.fw",
sep = "\n", header = FALSE)
#usually fixed-width conversion is harder, but everything here is numeric
columns = c("CRIM", "ZN", "INDUS", "CHAS",
"NOX", "RM", "AGE", "DIS", "RAD",
"TAX", "PTRATIO", "B", "LSTAT", "MEDV")
DT = with(x, fread(paste(gsub("\\s+", "\t", V1), collapse = "\n"),
header = FALSE, sep = "\t",
col.names = columns))
Here it is:
DT[ , fwrite(as.data.table(paste0(
MEDV, " | ", sapply(transpose(lapply(
names(.SD), function(jj)
paste0(jj, ":", get(jj)))),
paste, collapse = " "))),
"/path/to/output", col.names = FALSE, quote = FALSE),
.SDcols = !"MEDV"]
#what gets sent to as.data.table:
#[1] "24 | CRIM:0.00632 ZN:18 INDUS:2.31 CHAS:0 NOX:0.538 RM:6.575
# AGE:65.2 DIS:4.09 RAD:1 TAX:296 PTRATIO:15.3 B:396.9 LSTAT:4.98 MEDV:24"
#[2] "21.6 | CRIM:0.02731 ZN:0 INDUS:7.07 CHAS:0 NOX:0.469 RM:6.421
# AGE:78.9 DIS:4.9671 RAD:2 TAX:242 PTRATIO:17.8 B:396.9 LSTAT:9.14 MEDV:21.6"
# ...
There may be a better way to get this understood by fwrite than as.data.table, but I can't think of one (until setDT works on vectors).
I replicated this to test its performance on a bigger data set (just blow up the current data set):
DT2 = rbindlist(replicate(1000, DT, simplify = FALSE))
The operation was pretty fast compared to some of the times reported here (I haven't bothered comparing directly yet):
system.time(.)
# user system elapsed
# 8.392 0.000 8.385
I also tested using writeLines instead of fwrite, but the latter was better.
I am looking again and seeing it might take a while to figure out what's going on. Maybe the magrittr-piped version will be easier to follow:
DT[ ,
#1) prepend each column's values with the column name
lapply(names(.SD), function(jj)
paste0(jj, ":", get(jj))) %>%
#2) transpose this list (using data.table's fast tool)
# (was column-wise, now row-wise)
#3) concatenate columns, separated by " "
transpose %>% sapply(paste, collapse = " ") %>%
#4) prepend each row with the target value
# (with Vowpal Wabbit in mind, separate with a pipe)
paste0(MEDV, " | ", .) %>%
#5) convert this to a data.table to use fwrite
as.data.table %>%
#6) fwrite it; exclude nonsense column name,
# and force quotes off
fwrite("/path/to/data",
col.names = FALSE, quote = FALSE),
.SDcols = !"MEDV"]
reading in such files is much easier**
#quickly read data; don't split within lines
x = fread("/path/to/data", sep = "\n", header = FALSE)
#tstrsplit is transpose(strsplit(.))
dt1 = x[ , tstrsplit(V1, split = "[| :]+")]
#even columns have variable names
nms = c("target_name",
unlist(dt1[1L, seq(2L, ncol(dt1), by = 2L),
with = FALSE]))
#odd columns have values
DT = dt1[ , seq(1L, ncol(dt1), by = 2L), with = FALSE]
#add meaningful names
setnames(DT, nms)
**this will not work with "ragged"/sparse input data. I don't think there's a way to extend this to work in such cases.
Function to write a data.frame to svm light format. I've added a train={TRUE, FALSE} argument in case the data doesn't have labels. In this case, the class index is ignored.
write.libsvm = function(data, filename= "out.dat", class = 1, train=TRUE) {
out = file(filename)
if(train){
writeLines(apply(data, 1, function(X) {
paste(X[class],
apply(cbind(which(X!=0)[-class],
X[which(X!=0)[-class]]),
1, paste, collapse=":"),
collapse=" ")
}), out)
} else {
# leaves 1 as default for the new data without predictions.
writeLines(apply(data, 1, function(X) {
paste('1',
apply(cbind(which(X!=0), X[which(X!=0)]), 1, paste, collapse=":"),
collapse=" ")
}), out)
}
close(out)
}
** EDIT **
library(data.table)
data.table.fm <- function (data = X, fileName = "../out.fm", target = "y_train",
train = TRUE) {
if (train) {
if (is.logical(data[[target]]) | sum(levels(factor(data[[target]])) ==
levels(factor(c(0, 1)))) == 2) {
data[[target]][data[[target]] == TRUE] = 1
data[[target]][data[[target]] == FALSE] = -1
}
}
specChar = "\\(|\\)|\\||\\:"
specCharSpace = "\\(|\\)|\\||\\:| "
parsingNames <- function(x) {
ret = c()
for (el in x) ret = append(ret, gsub(specCharSpace, "_",
el))
ret
}
parsingVar <- function(x, keepSpace, hard_parse) {
if (!keepSpace)
spch = specCharSpace
else spch = specChar
if (hard_parse)
gsub("(^_( *|_*)+)|(^_$)|(( *|_*)+_$)|( +_+ +)",
" ", gsub(specChar, "_", gsub("(^ +)|( +$)",
"", x)))
else gsub(spch, "_", x)
}
setnames(data, names(data), parsingNames(names(data)))
target = parsingNames(target)
format_vw <- function(column, formater) {
ifelse(as.logical(column), sprintf(formater, j, column),
"")
}
all_vars = names(data)[!names(data) %in% target]
cat("Reordering data.table if class isn't first\n")
target_inx = which(names(data) %in% target)
rest_inx = which(!names(data) %in% target)
cat("Adding Variable names to data.table\n")
for (j in rest_inx) {
column = data[[j]]
formater = "%s:%f"
set(data, i = NULL, j = j, value = format_vw(column,
formater))
cat(sprintf("Fixing %s\n", j))
}
data = data[, c(target_inx, rest_inx), with = FALSE]
drop_extra_space <- function(x) {
gsub(" {1,}", " ", x)
}
cat("Pasting data - Removing extra spaces\n")
data = apply(data, 1, function(x) drop_extra_space(paste(x,
collapse = " ")))
cat("Writing to disk\n")
write.table(data, file = fileName, sep = " ", row.names = FALSE,
col.names = FALSE, quote = FALSE)
}
I went with a two-hop solution - convert R data to another format first, and then to LIBSVM:
My data set is 200K x 500 and this only took 3-5 minutes.
The question was asked a long time ago and has several answer. Most answers didn't work for me since my data comes in a long format, and I cant one-hot encode it in R. So here is my take. I wrote a function to one-hot encode the data, and save it without having to first transform the matrix into a sparse one.
RCPP code:
// [[Rcpp::depends(RcppArmadillo)]]
#include <RcppArmadillo.h>
#include <Rcpp.h>
#include <iostream>
#include <fstream>
#include <string>
using namespace Rcpp;
// Reading data frame from R and saving it as an libFM file
// [[Rcpp::export]]
std::string createNumber(int x, double y) {
std::string s1 = std::to_string(x);
std::string s2 = std::to_string(y);
std::string X_elem = s1 + ":" + s2;
return X_elem;
}
// [[Rcpp::export]]
std::string createRowLibFM(arma::rowvec row_to_fm, arma::vec factor_levels, arma::vec position) {
int n = factor_levels.n_elem;
std::string total = std::to_string(row_to_fm[0]);
for (int i = 1; i < n; i++) {
if (factor_levels[i] > 1) {
total = total + " " + createNumber(position[i - 1] + row_to_fm[i], 1);
}
if (factor_levels[i] == 1) {
total = total + " " + createNumber(position[i], row_to_fm[i]);
}
}
return total;
}
// [[Rcpp::export]]
void writeFile(std::string file, arma::mat all_data, arma::vec factor_levels) {
int n = all_data.n_rows;
arma::vec position = arma::cumsum(factor_levels);
std::ofstream temp_file;
temp_file.open (file.c_str());
for (int i = 0; i < n; i++) {
std::string temp_row = createRowLibFM(all_data.row(i), factor_levels, position);
temp_file << temp_row + "\n";
}
temp_file.close();
}
R function acting as wrapper for it:
writeFileFM <- function(temp.data, path = 'test.txt') {
### Dealing with y function
if (!(any(colnames(temp.data) %in% 'y'))) {
stop('No y column is given')
} else {
temp.data <- temp.data %>% select(y, everything()) ## y is required to be first column for writeFile
}
### Dealing with factors/strings
temp.classes <- sapply(temp.data, class)
class.num <- rep(0, length(temp.classes))
map.list <- list()
for (i in 2:length(temp.classes)) { ### since y is always the first column
if (any(temp.classes[i] %in% c('factor', 'character'))) {
temp.col <- as.factor(temp.data[ ,i]) ### incase it is character
temp.unique <- levels(temp.col)
factors.new <- seq(0, length(temp.unique) - 1, 1)
levels(temp.col) <- factors.new
temp.data[ ,i] <- temp.col
### Saving changes
class.num[i] <- length(temp.unique)
map.list[[i - 1]] <- data.frame('original.value' = temp.unique,
'transform.value' = factors.new)
} else {
class.num[i] <- 1 ### Numeric values require only 1 column
}
}
### Writing file
print('Writing file to disc')
writeFile(all_data = sapply(temp.data, as.numeric), file = path, factor_levels = class.num)
return(map.list)
}
Comparing it on fake data.
### Creating data to save
set.seed(999)
n <- 10000
factor.lvl1 <- 3
factor.lvl2 <- 2
temp.data <- data.frame('x1' = sample(stri_rand_strings(factor.lvl1, 7), n, replace = TRUE),
'x2' = sample(stri_rand_strings(factor.lvl2, 4), n, replace = TRUE),
'x3' = rnorm(n),
'x4' = rnorm(n),
'y' = rnorm(n))
### Comparing to other method
library(data.table)
library(e1071)
microbenchmark::microbenchmark(
temp.data.table <- model.matrix( ~ 0 + x1 + x2 + x3 + x4, data = temp.data,
contrasts = list(x2 = contrasts(temp.data$x2, contrasts = FALSE))),
write.matrix.csr(temp.data.table, 'out.txt'),
writeFileFM(temp.data))
Results.
min lq mean median uq
1.3061 1.6725 1.890942 1.92475 2.07725
629.9863 653.4345 676.108548 672.52510 687.88330
270.8217 275.1353 283.537898 281.42100 289.39160
max neval cld
3.2328 100 a
793.7040 100 c
328.0863 100 b
It is faster than the e1071 option, and while that option fails when increasing the number of observations, the method suggested is still applicable.
library(sos); findFn("libsvm")suggestse1071::write.svm, although I'm not sure if that does what you want? – Ben Bolker