#The Diagnostic functions (output site/censor information and the lagplot)
#for the predict from data EventData object
##' @include eventData.R
NULL
##' Output a data frame containing all subjects who been censored before
##' a given date
##'
##' Output a data frame containing all subjects who been censored before
##' a given date not including subjects censored at end of follow up period
##'
##' @param object An \code{EventData} object
##' @param ... Additional parameters to be passed to the method
##' @return A data frame with the required subject's data
##' @rdname censorInformation-methods
##' @name censorInformation
##' @export
setGeneric("censorInformation",function(object,...) standardGeneric("censorInformation"))
# Simple internal function for validating the analysis/censor date
# arguments for the Diagnostic functions
# @param date.arg The user's input date
# @param default.date The default date to use if date.arg is null
# @return date.arg or the default.date if date.arg is null
# errors validating date.arg will throw an exception
DiagDataArg <- function(date.arg,default.date){
if(is.null(date.arg)){
return(as.Date(default.date,origin="1970-01-01"))
}
FixDates(date.arg)
}
##' @param censor.date All subjects who have a censor date before this
##' date should be output, by default (i.e. when NULL) the latest date for which
##' any subject information (withdrawal/event/censor) is known
##' @name censorInformation
##' @aliases censorInformation,EventData-method
##' @rdname censorInformation-methods
##'@export
setMethod("censorInformation", "EventData",
function(object, censor.date=NULL){
censor.date <- DiagDataArg(censor.date,max(LastDate(object@subject.data)))
data <-GetLaggedSubjects(object@subject.data,censor.date)
if(nrow(data)==0){
return(data.frame(subject=character(0),
timelag=numeric(0),
rand.date=numeric(0),
time=numeric(0)))
}
last.date <- LastDate(data)
data <- data.frame(subject=data$subject,
timelag=as.numeric(censor.date-last.date),
rand.date=data$rand.date,
time=data$time)
ans <- data[order(data$timelag,decreasing=TRUE),]
rownames(ans) <- 1:nrow(ans)
ans
})
##' Output a plot showing the lag between censoring and the date the analysis
##' is being performed
##' @param object An \code{EventData} object
##' @param ... Additional arguments for the function
##' @rdname DiagnosticPlot-methods
##' @name DiagnosticPlot
##' @export
setGeneric("DiagnosticPlot",function(object,...) standardGeneric("DiagnosticPlot"))
##' @param window.size An optional integer. If used an additional 2 lines at y=x-window.size
##' and y = x-2*window.size are drawn on the graph. If \code{window.size} is chosen to be the
##' visit schedule (in days) then these lines provide an easy way to determine the number of subjects
##' who have missed one or two visits.
##' @param analysis.date The date the analysis is being perfomed on, by default (i.e. when NULL) it is the
##' the latest date at which any subject is censored/is known to have had an event
##' @param separate.events Logical, if FALSE then all events are coloured the same with label "Had Event", if
##' TRUE then the different event types (object@@subject.data$event.type) are coloured individually.
##' @rdname DiagnosticPlot-methods
##' @aliases DiagnosticPlot,EventData-method
##' @name DiagnosticPlot
##' @export
setMethod("DiagnosticPlot","EventData",
function(object, window.size=NULL, analysis.date=NULL,separate.events=TRUE){
if(nrow(object@subject.data)==0)stop("Empty data frame!")
analysis.date <- DiagDataArg(analysis.date,max(LastDate(object@subject.data)))
xlab <- paste("Days on study if subjects censored on",as.character(analysis.date))
ylab <- "Known days on study"
time.on.study <- object@subject.data$time
status <- rep("Ongoing",nrow(object@subject.data))
status <- ifelse(object@subject.data$has.event==1,
if(separate.events)as.character(object@subject.data$event.type) else "Had Event",status)
status <- ifelse(object@subject.data$censored.at.follow.up==1,"Censored after follow up period",status)
status <- ifelse(object@subject.data$withdrawn==1,"Withdrawn from Study",status)
my.data <- data.frame(subject=object@subject.data$subject,
rand.date=object@subject.data$rand.date,
time.on.study=time.on.study,
t.max=as.numeric(analysis.date - object@subject.data$rand.date + 1,origin="1970-01-01"),
status=status,
site=object@subject.data$site,
date.of.event.censor.or.withdrawal=LastDate(object@subject.data))
p <- ggplot(my.data, aes_string(x="t.max", y="time.on.study", color="status")) +
geom_point() + geom_abline(intercept=0, slope=1, col="black") +
xlab(xlab) + ylab(ylab)
if(!is.null(window.size)){
if(window.size<=0) stop("window.size should be positive")
p <- p + geom_abline(intercept=-window.size, slope=1, col="black",linetype = 2)+
geom_abline(intercept=-2*window.size, slope=1, col="black",linetype = 2)
}
p
}
)
##' Output information about how up to date subject censor dates
##' are for each site
##'
##' Output information about how up to date subject censor dates
##' are for each site in the study subjects who are censored at the
##' end of their follow up period are
##' not included in this analysis
##' @param object An \code{EventData} object
##' @param ... Additional arguments to be passed to the method
##' @rdname siteInformation-methods
##' @name siteInformation
##' @export
setGeneric("siteInformation",function(object,...) standardGeneric("siteInformation"))
##'@param analysis.date The date the analysis is being perfomed on, by default (i.e. when NULL) it is the
##' the latest date at which any subject is censored/is known to have had an event
##'@param ndays The acceptable lag between \code{analysis.date} and censor date. If the lag is
##'greater than this then the subject will be included in the output data frame.
##'@return A data frame with each row containing a site name and the number
##'of subjects at this site with censor date before \code{analysis.date}-\code{ndays}
##'@rdname siteInformation-methods
##'@aliases siteInformation,EventData-method
##'@name siteInformation
##'@export
setMethod("siteInformation", "EventData",
function(object, analysis.date=NULL, ndays){
if(ndays < 0 || class(ndays)!="numeric") stop("ndays must be numeric and non-negative")
if(all(is.na(object@subject.data$site))) stop("No site information")
analysis.date <- DiagDataArg(analysis.date,max(LastDate(object@subject.data)))
data <-GetLaggedSubjects(object@subject.data,analysis.date-ndays)$site
if(length(data)==0){
return(data.frame(site=character(0),count=character(0)))
}
sites <- as.data.frame(table(data))
colnames(sites) <- c("site","count")
sites <- sites[order(sites$count,decreasing=TRUE),]
rownames(sites) <- NULL
sites[sites$count > 0,]
})
