# Do a set of error checks on whether any categorical vars match the
# level set of the actual ratetable. If so they are mapped to the levels
# found in the ratetable. Dates need to match dates, and others are set
# to simple numerics with unclass(). A matrix is returned.
# This is called by pyears and survexp, but not by users
#
# The categoricals are turned into integer subscripts
#
match.ratetable <- function(R, ratetable) {
datecheck <- function(x)
inherits(x, c("Date", "POSIXt", "date", "chron", "rtabledate"))
if (!is.ratetable(ratetable)) stop("Invalid rate table")
dimid <- names(dimnames(ratetable))
if (is.null(dimid)) dimid <- attr(ratetable, 'dimid') # older ratetable
datecut <- sapply(attr(ratetable, "cutpoints"), datecheck)
rtype <- attr(ratetable, 'type') # 1= class, 2=cont, 3=date, 4=US yr
if (is.null(rtype)) { #old style ratetable, be backwards compatable
temp <- attr(ratetable, 'factor')
rtype <- 1*(temp==1) + ifelse(datecut, 3,2)*(temp==0) + 4*(temp >1)
}
# is.ratetable has ensured that rtype agrees with datecut
if (is.matrix(R)) {
# depricated: use of the ratetable function
attR <- attributes(R)
attributes(R) <- attR['dim'] #other attrs get in the way later
Rnames <- attR$dimnames[[2]]
isDate <- attR[["isDate"]]
levlist <- attR[['levlist']]
}
else { # newer style is a dataframe
Rnames <- names(R)
levlist<- lapply(R, levels)
isDate <- sapply(R, datecheck)
}
ord <- match(dimid, Rnames)
# This should have already been checked in pyears or survexp
if (any(is.na(ord)))
stop(paste("Argument '", dimid[is.na(ord)],
"' needed by the ratetable was not found in the data", sep=''))
# Neither should this -- two argments matched one of the dimids -- since
# I demand an exact match
if (any(duplicated(ord)))
stop("A ratetable argument appears twice in the data")
R <- R[,ord,drop=FALSE] #put cols in same order as the ratetable
levlist<- levlist[ord]
isDate <- isDate[ord]
# Now, go through the dimensions of the ratetable 1 by 1, and
# verify that the user's variable is compatable
# with the rate table's dimensions
#
dtemp <-dimnames(ratetable)
if (any((rtype<3) & isDate)) {
indx <- which(rtype<3 & isDate)
stop(paste("Data has a date type variable, but the reference",
"ratetable is not a date variable:",
paste(dimid[indx], collapse=" ")))
}
if (any((rtype>2) & !isDate)) {
indx <- which(rtype>2 & !isDate)
# currently relsurv fails with this check
# stop(paste("the reference ratetable expects a date for variable",
# dimid[indx]))
}
for (i in (1:ncol(R))) {
if (rtype[i] > 2) R[,i] <- ratetableDate(R[,i])
if (length(levlist[[i]]) >0) { #factor or character variable
if (rtype[i]!=1) stop(paste("for this ratetable,", dimid[i],
"must be a continuous variable"))
temp <- charmatch(casefold(levlist[[i]]), casefold(dtemp[[i]]))
if (any(is.na(temp)))
stop(paste("Levels do not match for ratetable() variable",
dimid[i]))
if (any(temp==0))
stop(paste("Non-unique ratetable match for variable",
dimid[i]))
R[,i] <- temp[as.numeric(R[,i])]
}
else { # user's data isn't a factor or date
R[,i] <- unclass(R[,i]) # get rid of difftimes & other such
if (rtype[i]==1) { #ratetable is a factor: ok if data is integer
temp <- R[,i]
if (any(floor(temp)!=temp) || any(temp<=0) ||
max(temp) > length(dtemp[[i]]))
stop(paste("The variable", dimid[i], "is out of range"))
}
}
}
R <- as.matrix(R)
summ <- attr(ratetable, 'summary')
cutpoints <- lapply(attr(ratetable, 'cutpoints'), ratetableDate)
if (is.null(summ))
list(R= R, cutpoints = cutpoints)
else list(R= R, cutpoints = cutpoints, summ=summ(R))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.