--- a +++ b/R/summaryText.R @@ -0,0 +1,225 @@ +#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="") + +} +