R/summaryText.R

In scientific-computing-solutions/eventPrediction: Event Prediction in Clinical Trials with Time-to-Event Outcomes

#File which outputs the summary text for the
#predict from parameters part of the package
#In future refactoring away this summary text
#(maybe replacing with a table of output) will
#improve maintainability?

##' @include common.R
NULL

# Creates the text to be output when calling
# summary of an AnalysisResults object
# 
# @param object An AnalysisResults object
# @param options DisplayOptions
# @return The summary text 
getFromParameterText <-function(object,options){
  study <- object@study
  daysinyear <- standarddaysinyear()
  ####### generate summary text about assumptions ######
  ####  Start date   ######
  startd <- as.Date( options@StartDate, format="%d/%m/%Y")
  date2  <- as.Date(startd+(0:length(t))*daysinyear/12, format="%d/%m/%Y")
  date   <- format(date2, format="%d/%m/%Y")
  date3  <- format(date2, format="%b %Y")
  
  recruit.txt <- ''
  if( options@Trecruit ) {
    recruit.txt <- paste0( study@N,' patients recruited, ')
    if(!is.infinite(study@followup)){
      recruit.txt <- paste0(recruit.txt,"and are followed for ",study@followup," ",options@Time,", ")
    }  
  }
  
  ratio.txt <- ''
  if( options@Tratio && !isSingleArm(study) ) {
    ratio.txt <- paste0('ratio nE/nC=',study@r,', ')
  }
  
  acc.txt <- ''
  if( options@Tacc) {
    if( study@k==1 ) {
      acc.txt <- paste0( study@acc.period,' ', options@Time,' accrual (uniform accrual, k=', study@k, ').' )
    }  
    else{ 
      acc.txt <- paste0( study@acc.period, ' ', options@Time, ' accrual (non-uniform accrual, k=', study@k, ').' )
    }  
  }
  
  
  median.txt <- ''
  hr.txt <- ''
  
  if(!isNullLag(study@lag.settings) ){
    
    if( options@Tmedian) {
      median.txt <- paste0('Lag time: T=', study@lag.settings@Lag.T, " ", options@Time, ', ', options@Control, 
                           ' for [0,T] ', study@lag.settings@ctrlSpec@text, 
                           " ", options@Time,' and for [T,S] ', options@Control," " ,
                           study@ctrlSpec@text, " ", options@Time, "." )
    
      
    }
    
    if( options@Thr && !isSingleArm(study) ) {          
      hr.txt <- paste0('HR([0,T])=', study@lag.settings@L.HazardRatio, ' and HR([T,S])=', 
                       study@HR, ', which gives an average HR=',round( object@av.hr, digits=2 ),'. ')
    }
          
  }
  else{
    
    if( options@Tmedian) {
      median.txt <- paste0( options@Control," ", study@ctrlSpec@text," ", options@Time,' (lambda=',round( object@sfns[[1]]@lambda, digits=2 ),'). ')
      if(!isSingleArm(study))                      
        median.txt <- paste0(median.txt, options@Exp,' ', study@ctrlSpec@experimentaltext(study@HR,study@shape),
                             " ",options@Time,' (lambda=', round( object@sfns[[2]]@lambda, digits=2 ),').')
    }
    
    if( options@Thr && !isSingleArm(study)) {
      hr.txt <- paste0('HR(', options@Exp, ':', options@Control, ')=', round( study@HR, digits=2 ),', ')
    }
  }     
  
  
  if(options@Tmedian){
    if(object@study@shape!=1) 
      median.txt <- paste(median.txt," Weibull survival function shape=",object@study@shape,".",sep="")
    else{
      median.txt <- paste(median.txt," Exponential survival function.",sep="") 
    }
  }
  
  
  dropout.txt <- ""
  if(options@Dropout){
    if(!is.infinite(object@study@dropout[[1]]@median)){
      dropout.txt <- paste(options@Control,"dropout:",object@study@dropout[[1]]@text,options@Time)
    }
    
    if(!isSingleArm(study) && !is.infinite(object@study@dropout[[2]]@median)){
      dropout.txt <- paste(dropout.txt,"and",options@Exp ,"dropout:",object@study@dropout[[2]]@text,options@Time,"both arms")  
    }
    
    if(dropout.txt!=""){
      if(object@study@dropout.shape==1){
        dropout.txt <- paste(dropout.txt," using exponential dropout rate.")
      }
      else{
        dropout.txt <- paste(dropout.txt," using Weibull dropout with shape=",object@study@dropout.shape,".",sep="")
      }
    }
  
  } 
   
  
  crithr.txt <- ''
  if( options@Tcrithr && !isSingleArm(study)) {
    if(isNullLag(study@lag.settings)){
      crithr.txt <- paste0('critical HR value=',floor( object@critical.HR*100)/100,', ')
    }
    else{
      crithr.txt <- paste0('For a study with no lag and this HR: critical HR value=',floor( object@critical.HR*100)/100,', ')  
    }
  }
  
  if(isSingleArm(study)){
    param.txt <- ''
  }else if( study@two.sided )  { 
    param.txt <- paste0('alpha(2-sided)=', study@alpha*100,'%, power=', round(study@power*100,digits=0),'%,')
  }   
  else{
    param.txt <- paste0('alpha(1-sided)=', study@alpha*100,'%, power=', round(study@power*100,digits=0),'%,')
  }
  
  line1.txt <- paste0( recruit.txt, ratio.txt, acc.txt )
  line3.txt <- paste0( hr.txt, crithr.txt, param.txt )
  
  ####### generate text about events required and when reached ######
  if( nrow(object@critical.data)>0 ) {
    at.txt <- paste( 'expected at time', floor(object@critical.data[1,"time"]*10)/10, options@Time )
    at.txt <- paste(at.txt,' (',options@Exp,'/',options@Control,': ', trunc( object@critical.data[1,"events2"] ),'/',
                    trunc( object@critical.data[1,"events1"]),').',sep="")
  } 
  else { 
    at.txt <- paste( 'not reached by time ', study@study.duration,".",sep="")
  }
  
  if(isSingleArm(study)){
    events1.txt <- ''
  }
  else{
    elag.txt <- if(isNullLag(study@lag.settings)) '' else "and using the given lag settings: "
    events1.txt <- paste( ceiling( object@critical.events.req ),' events required ',elag.txt,at.txt,sep='')
  }
  
  
  summary1.txt <- paste(line1.txt, median.txt,dropout.txt)
  summary2.txt <- paste(line3.txt, events1.txt)
  summary3.txt <- GetPredictionText(object,options,study@power,isSingleArm(study)) 
  
  return( AddLineBreaks( paste(summary1.txt, summary2.txt, summary3.txt ),text.width=options@text.width)) 
}


# Generates the text for the Analysis results concerning the number of
# events occurring at user chosen time.pred times
# 
# @param results A results object
# @param options A DisplayOptions object
# @param study.power The power of the study
# @param isSingleArm Logical, True if study is single arm
# @return The text concerning the number of events occurring at user chosen time.pred times
GetPredictionText <- function(results,options,study.power,isSingleArm){
  p.df <- results@predict.data
  if(nrow(p.df)==0) return("")
  
  events2.txt <- ""
  
  if(nrow(p.df)>1){
    l <- "("
    r <- ")"
  }
  else{
    l <- ""
    r <- ""
  }
    
    
  output_times <- paste(l,paste(round(p.df$time,digits=1),collapse=", "),r,sep="")
    
  pred_events <- floor( p.df[,"events1"] ) + floor(p.df[,"events2"] )
  pred_events <- paste(l,paste(pred_events,collapse=", "),r,sep="")
        
  if("at.risk1" %in% colnames(p.df)){
    atrisk.value <- round(options@atRiskConversion*(p.df[,"at.risk1"] +p.df[,"at.risk2"]),digits=2)
    atrisk.value <- paste(l,paste(atrisk.value,collapse=", "),r,sep="")
  }
  else{
    atrisk.value <- NA
  }
    
  control_events <- paste(l,paste(trunc( p.df[,"events1"] ),collapse=", "),r,sep="") 
  exp_events <- paste(l,paste(trunc( p.df[,"events2"] ),collapse=", "),r,sep="") 
    
  events2.txt <- paste0("At ", output_times,' ',options@Time," the predicted number of events is ", 
                        pred_events)
    
  if(!isSingleArm){
    events2.txt <- paste0(events2.txt,' [',options@Exp,'/',options@Control,': ',exp_events,'/',control_events,']')     
  }
    
  if(options@ShowRec){
    recs <- floor(p.df[,"recruit.tot"])
    recs <- paste(l,paste(recs,collapse=", "),r,sep="")
    events2.txt <- paste0(events2.txt," and the expected number of subjects recruited is ", recs,sep="")
  }
    
  if(options@showatRisk && !is.na(atrisk.value)){
    events2.txt <- paste0(events2.txt," with a total of ", atrisk.value ," patient ", options@atRiskTime, " at risk",sep="")
  }
  
  paste(events2.txt,".",sep="")

}