Nothing
# genSamples.r: functions to extract subsets of data sets
# (e.g. for training sets)
genSamples = function (dataset, num.non, des.mprop=0.1)
{
# catch erronous input
# for dataset: errors are detected in classifyUnsup
if (!is.numeric(num.non))
stop("Illegal type for num.non!")
if (!is.numeric(des.mprop))
stop("Illegal type for des.mprop!")
if (num.non <0)
stop(sprintf("Illegal value for num.non: %g", num.non))
if (des.mprop <= 0)
stop(sprintf("Illegal value for des.mprop: %g", num.non))
# run clustering algorithm?
# res_clust <- bclust(x=ddmat, centers=3,base.center=2, base.method="kmeans", iter.base=100, verbose=TRUE)
# kmendundet<-kmeans(x=ddmat, centers=nclasses); pairs$pairs[kclusr$cluster==2,]
# Use EM algorithm instead
# ddpairs <- emWeights(datapairs)
# ddclass <- emClassify(ddpairs)
ddclass=classifyUnsup(dataset,method="bclust")
return(splitData(ddclass, use.pred=TRUE, num.non=num.non, des.mprop=des.mprop))
}
splitData <- function(dataset, prop=0.5, keep.mprop=FALSE, num.non=0,
des.mprop=0, use.pred=FALSE)
{
# catch erronous input
if (!(("RecLinkData" %in% class(dataset)) ||
"RecLinkResult" %in% class(dataset)))
stop("Wrong class for dataset!")
if (nrow(dataset$pairs) < 2)
stop("Not enough data!")
if (prop <= 0 || prop >= 1)
stop(sprintf("Illegal value for prop: %g!", prop))
if (num.non <0)
stop(sprintf("Illegal value for num.non: %g", num.non))
if (!is.numeric(num.non))
stop(sprintf("Illegal type of num.non: %s", typeof(num.non)))
train=dataset
valid=dataset
pairs=dataset$pairs
n_data=nrow(pairs)
pairs$is_match=as.logical(pairs$is_match)
if (use.pred)
{
if (is.null(dataset$prediction))
stop ("No prediction vector in dataset! Call with use.pred=FALSE.")
pairs$is_match=dataset$prediction=="L"
}
if (!missing(num.non) && !missing(des.mprop))
{
#ids=as.matrix(ret$pairs[,c(1:2)]) # any filters will be set
ids <- seq(from=1,to=n_data)
nlink <- round(des.mprop*(num.non))
ngesamt <- num.non+nlink
if (ngesamt > n_data)
stop("Inconsistent values for training data!")
if (des.mprop<0 || des.mprop >=1)
stop("Inconsistent value for link proportion!")
linksid <- ids[pairs$is_match]
nonlinksid <- ids[!pairs$is_match]
alidn <- length(linksid)
anolidn <- length(nonlinksid)
nmark=FALSE; mmark=FALSE;
if(nlink > alidn) { warning("Only ", alidn, " Links!"); nlink=alidn; nmark=TRUE }
if(num.non > anolidn) { warning("Only ", anolidn, " Non-Links!"); num.non=anolidn; mmark=TRUE }
salid <- resample(linksid, size=nlink)
sanolid <- resample(nonlinksid, size=num.non)
train=dataset
valid=dataset
trainid <- c(salid,sanolid)
trainhelp <- ids %in% trainid
linkhelp <- ids %in% salid
nonlinkhelp <- ids %in% sanolid
valid$pairs <- dataset$pairs[!trainhelp,]
train$pairs <- dataset$pairs[trainhelp,]
# split prediction vector, if present
if (!is.null(dataset$prediction))
{
valid$prediction <- dataset$prediction[!trainhelp]
train$prediction <- dataset$prediction[trainhelp]
}
# split weight vector, if present
if (!is.null(dataset$Wdata))
{
valid$Wdata=dataset$Wdata[!trainhelp]
train$Wdata=dataset$Wdata[trainhelp]
valid$M=dataset$M
valid$U=dataset$U
valid$W=dataset$W
train$M=dataset$M
train$U=dataset$U
train$W=dataset$W
}
return(list(train=train,valid=valid))
}
if (isFALSE(keep.mprop))
{
s=sample(1:n_data,n_data*prop)
train$pairs=dataset$pairs[s,]
valid$pairs=dataset$pairs[-s,]
# split prediction vector, if present
if (!is.null(dataset$prediction))
{
train$prediction <- dataset$prediction[s]
valid$prediction <- dataset$prediction[-s]
}
# split weight vector, if present
if (!is.null(dataset$Wdata))
{
train$Wdata=dataset$Wdata[s]
valid$Wdata=dataset$Wdata[-s]
valid$M=dataset$M
valid$U=dataset$U
valid$W=dataset$W
train$M=dataset$M
train$U=dataset$U
train$W=dataset$W
}
return (list(train=train, valid=valid))
}
if (isTRUE(keep.mprop))
{
match_ind=which(as.logical(pairs$is_match))
n_match=length(match_ind)
if (n_match==0)
stop("No matches found! Call with keep.mprop=FALSE.")
s_match=sample(1:n_match,round(n_match*prop))
s_non_match=sample(1:(n_data-n_match),round(n_data*prop)-round(n_match*prop))
train$pairs=rbind(dataset$pairs[match_ind[s_match],],
dataset$pairs[-match_ind,][s_non_match,])
valid$pairs=rbind(dataset$pairs[match_ind[-s_match],],
dataset$pairs[-match_ind,][-s_non_match,])
# split prediction vector, if present
# c() removes levels, use workaround
if (!is.null(dataset$prediction))
{
train$prediction=c(dataset$prediction[match_ind[s_match]],
dataset$prediction[-match_ind][s_non_match])
class(train$prediction) <- "factor"
levels(train$prediction) <- levels(dataset$prediction)
valid$prediction=c(dataset$prediction[match_ind[-s_match]],
dataset$prediction[-match_ind][-s_non_match])
class(valid$prediction) <- "factor"
levels(valid$prediction) <- levels(dataset$prediction)
}
# split weight vector, if present
if (!is.null(dataset$Wdata))
{
train$Wdata=c(dataset$Wdata[match_ind[s_match]],
dataset$Wdata[-match_ind][s_non_match])
valid$Wdata=c(dataset$Wdata[match_ind[-s_match]],
dataset$Wdata[-match_ind][-s_non_match])
valid$M=dataset$M
valid$U=dataset$U
valid$W=dataset$W
train$M=dataset$M
train$U=dataset$U
train$W=dataset$W
}
return (list(train=train,valid=valid))
}
}
setGeneric(
name = "getMinimalTrain",
def = function(rpairs, nEx = 1) standardGeneric("getMinimalTrain")
)
if(getRversion() >= "2.15.1") utils::globalVariables("ID")
setMethod(
f = "getMinimalTrain",
signature = "RecLinkData",
definition = function(rpairs, nEx=1)
{
# catch erronous input
if (!(("RecLinkData" %in% class(rpairs)) ||
"RecLinkResult" %in% class(rpairs)))
stop("Wrong class for rpairs!")
if (nEx < 1)
stop(sprintf("Illegal value for nEx: %d!", nEx))
# check if fuzzy values occur
if (any(rpairs$pairs[,-c(1,2,ncol(rpairs$pairs))] > 0 &
rpairs$pairs[,-c(1,2,ncol(rpairs$pairs))] < 1, na.rm=TRUE))
warning("Comparison patterns in rpairs contain string comparison values!")
p <- rpairs$pairs
p[is.na(p)] <- 0
p=data.table(ID = 1:nrow(p), p)
keyCol <- names(rpairs$pairs)[-c(1,2,ncol(rpairs$pairs))]
setkeyv(p, keyCol)
sampleFun <- function(x) (x[sample(1:length(x),
min(length(x),nEx))])
trainind <- p[,sampleFun(ID), by=keyCol, nomatch=0]$V1
train=rpairs
train$pairs=rpairs$pairs[trainind,]
train$Wdata=rpairs$Wdata[trainind]
train$prediction=rpairs$prediction[trainind]
return(train)
}
)
setMethod(
f = "getMinimalTrain",
signature = "RLBigData",
definition = function(rpairs, nEx=1)
{
if (nEx < 1)
stop(sprintf("Illegal value for nEx: %d!", nEx))
o <- ffdforder(rpairs@pairs[3:(length(rpairs@pairs)-1)])
pairs <- rpairs@pairs[o,] # sort geht wahrscheinlich nicht, weil nicht nach allem sortiert wird (?)
nPairs <- nrow(rpairs@pairs)
thisPattern <- pairs[1,3:(ncol(pairs)-1)]
patInd <- list(1)
ffrowapply(
{
chunk <- pairs[i1:i2,3:(ncol(pairs)-1)] # wichtig, enorme Beschleunigung!
chunk[is.na(chunk)] <- 0
dupInd <- which(!duplicated(chunk))
if (isTRUE(all.equal(chunk[1,], thisPattern, check.attributes=FALSE))) dupInd <- dupInd[-1]
if (length(dupInd) > 0) patInd <- append(patInd, dupInd + i1 - 1)
thisPattern <- chunk[nrow(chunk),]
}, X = pairs)
# convert list of indices to vector, add nrow(pairs) + 1 as last element
# (position of a virtual additional pattern after the existent ones)
patInd <- c(unlist(patInd), nrow(pairs))
# draw training examples
trainInd <- list()
for (i in 1:(length(patInd) - 1))
{
thisPatCount <- patInd[i+1] - patInd[i]
trainInd[[i]] <- sample(thisPatCount, min(thisPatCount, nEx)) + patInd[i] - 1
}
trainPairs <- pairs[unlist(trainInd),]
retObject <- list(data = rpairs@data, pairs = as.data.frame(trainPairs),
frequencies = getFrequencies(rpairs), type = switch(class(rpairs),
RLBigDataDedup = "deduplication", RLBigDataLinkage = "linkage"))
class(retObject) <- "RecLinkData"
retObject
}
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.