Nothing
matchName <- function(x, data, Names=1:2,
nicknames=matrix(character(0), 0, 2),
namesNotFound="attr.replacement", ...){
##
## 1. Check x
##
x0 <- x
if(is.data.frame(x)){
x <- as.matrix(x)
}
if(!is.character(x)){
if(is.data.frame(x)){
stop('class(as.matrix(x)) must be character;',
' is ', class(x))
}
if(is.null(x))return(NULL)
stop('class(x) = ', class(x), '; must be either character',
' or a data.frame that can be converted to character')
}
dimx <- dim(x)
if(length(dimx)<2){
x <- parseName(x, namesNotFound=namesNotFound, ...)
} else if(length(dimx)>2){
stop('length(dim(x)) must be 1 or 2; is ', length(dimx))
}
##
## 2. Check data
##
dimd <- dim(data)
lend <- length(dimd)
if(lend != 2){
erd <- paste0('length(dim(data)) must be 2; is ', lend)
if(lend>0){
erd <- paste0(erd, "; dim(data) = ",
paste(dimd, collapse=', '))
}
stop(erd)
}
##
## 3. Names
##
Names0 <- Names
if(is.numeric(Names)){
if(any(Names<1)){
stop('Names is numeric so must be at least 1; is ',
paste(Names, collapse=', '))
}
if(any(trunc(Names)>dimd[2])){
stop('Names is numeric so must be at most dim(data)[2] = ',
dimd[2], '; is ', paste(Names, collapse=', '))
}
dn <- data[, Names]
Names <- subNonStandardNames(dn, namesNotFound=namesNotFound,
...)
} else if(is.logical(Names)){
if(length(Names) != dimd[2]){
stop('Names is logical, so its length must match dim(data)[2];',
' length(Names) = ', length(Names))
}
dn <- data[, Names]
Names <- subNonStandardNames(dn, namesNotFound=namesNotFound,
...)
} else if(is.character(Names)){
nNms <- NROW(Names)
if(nNms != dimd[1]){
chk <- (Names %in% colnames(data))
if(any(!chk)){
stop('Names is character, not found in colnames(data): ',
paste(Names[!chk], collapse=', '))
}
dn <- data[, Names]
Names <- subNonStandardNames(dn, namesNotFound=namesNotFound,
...)
}
} else stop('class(Names) must be either numeric, logical, or ',
'character; is ', class(Names))
##
## 4. nicknames
##
if(!is.character(nicknames)){
stop('nicknames must be character; are ', class(nicknames))
}
dimn <- dim(nicknames)
if(length(dimn) != 2){
ern <- paste0('nicknames must be a matrix; length(dim(nicknames)) = ',
length(dimn))
stop(ern)
}
##
## 5. xlist <- matchName1(x[, 1], data, Names[, 1], data, ...)
##
xlist <- matchName1(x[, 1], data, Names[, 1], ...)
# names(xlist) <- paste(x[, 1], x[, 2], sep=', ')
xRestore <- paste(x[, 1], x[, 2], sep=', ')
xR <- sub('^, ', '', xRestore)
names(xlist) <- xR
##
## 6. For any component i of xlist with 0 or multiple rows
##
id <- seq(length=dimd[1])
nx <- NROW(x)
out <- vector(nx, mode='list')
names(out) <- names(xlist)
for(ix in seq(length=nx)){
jd <- xlist[[ix]]
ni <- length(jd)
if(ni != 1){
# if(ni<1)jd <- id
# If ni < 1: No match for first name; next
if(ni<1)next
xi <- strsplit(x[ix, 2], ' ')[[1]]
for(j in seq(along=xi)){
# jd2 <- matchName1(xi[j], data[jd,, drop=FALSE],
# Names[jd, -1, drop=FALSE], nicknames=nicknames, ...)[[1]]
# jd2 <- matchName1(xi[j], data[jd,],
# Names[jd, -1, drop=FALSE], nicknames=nicknames, ...)[[1]]
jd2 <- matchName1(xi[j], data[jd,], Names[jd, -1],
nicknames=nicknames, ...)[[1]]
if(length(jd2)>0){
jd <- jd[jd2]
# if(length(jd)<2) next
if(length(jd)<2) break # j
} # else if(length(jd2)<2) break
}
}
ni <- length(jd)
if((0<ni) & (ni < dimd[1]))out[[ix]] <- data[jd,, drop=FALSE]
}
##
## 7. done
##
notF <- c(attr(x, 'namesNotFound'),
attr(Names, 'namesNotFound'))
if(length(notF)>0){
attr(out, 'namesNotFound') <- notF
}
out
}
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.