R/GenericFunctions.R

In CTP: Closed Testing Procedure (CTP)

#'	Summarising and plotting the results of hypothesis trees and closed testing procedures
#'
#'  The functions \code{summary.ctp.str} and \code{Display.ctp.str} summarise and plot the hypothesis tree of a closed testing procedure,
#'	whereas the functions \code{summary.ctp} and \code{Display.ctp} summarise and plot the results of a closed testing procedure.
#'
#'  @name Generic_Functions
#'
#'  @aliases summary Display
#'
#'	@param object Object generated by \code{\link{AnalyseCTP}} or \code{\link{IntersectHypotheses}}.
#'
#'	@param digits The minimum number of significant digits to be printed for the p-values in the summary.
#'
#'	@param Type Type of the plotted tree: \code{"s"} straight lines, \code{""} tree type.
#'
#'	@param arrow If \code{TRUE}, an arrow is plotted in the connections.
#'
#'	@param ... Additional arguments passed to \code{Display}.
#'
#'
#' @note \code{Disply.ctp.str} plots the hypothesis tree. \cr \code{Display.ctp} plots the hypothesis
#'     tree together with the unadjusted and adjusted p-values.
#'
#' @return
#' \itemize{
#'	\item \code{summary.ctp.str} provides lists with dataframes comprising the hypothesis names as strings
#'	     and the relationship between the hypotheses.
#'	\item \code{summary.ctp} provides a table of hypotheses, raw p-values and
#'	    adjusted p-values.
#'  }
#'
#' @seealso  \code{\link{IntersectHypotheses}}, \code{\link{AnalyseCTP}}
#'
#' @rdname Generic_functions
#'
#' @export
#' @import diagram
#'
summary.ctp <- function(object,digits=4,...)
  {
    Parms <- object$CTPparms

    if(!is.null(Parms$nlevel)) levtxt <- paste(1:Parms$nlevel, "=", Parms$level, sep = "",
                    collapse = ", ")
    subtxt <- paste("Model :",Parms$model[2],
                    "~", Parms$model[3], ", test :", strsplit(Parms$test,split="[.]")[[1]][2])
    
    if(!is.null(Parms$test.opt))
      {
       l_opt <- length(Parms$test.opt)
       n_opt <- names(Parms$test.opt)
       opt   <- unlist(Parms$test.opt)
       subtxt2 <- ""
       for (i in 1:l_opt) subtxt2 <- paste(subtxt2,n_opt[i],":",opt[i],"  ")
      }
    
    X <- object$pvalues
    names(X) <- c("x","Level","Hypothesis","raw p-value","adj. p-value")

    cat("\nSummary of Closed Testing Procedure\n===================================\n\n")
    if(!is.null(Parms$model)) cat(subtxt,"\n")
    if(!is.null(Parms$test.opt)) cat("\nTest options:",subtxt2,"\n")
    if(!is.null(Parms$level)) cat("\nFactor levels:",levtxt,"\n\n")
      
    cat("Elementary Hypotheses and p-values\n----------------------------------\n\n")
    X2 <- subset(X,Level==1)
    print(X2[,c(3,4,5)],row.names=FALSE,digits=digits)
    invisible()
  }
#' @rdname Generic_functions
#' @export

summary.ctp.str <- function(object,...)
{

  tree  <- object$hypnames
  con   <- object$connections

  ncon <- length(con)
  Con  <- con[[1]]
  if (ncon >1)
  {
    for (i in 2:ncon) Con <- rbind(Con,con[[i]])
  }


  From   <- Con %>% dplyr::select(level=levold,hyp.no=hypold) %>%
    left_join(tree,by = c("level", "hyp.no")) %>% suppressMessages() %>%
    rename(Hypothesis_1 =hypothesis.name,Level_1=level )

  To   <- Con %>% dplyr::select(level=levnew,hyp.no=hypnew) %>% suppressMessages() %>%
                  left_join(tree,by = c("level", "hyp.no"))  %>%
                   rename(Hypothesis_2 =hypothesis.name,Level_2=level )



  Connections  <- cbind(From,To) %>%
                        dplyr::select(Level_1,Hypothesis_1,Level_2,Hypothesis_2) %>%
                        arrange(Level_1,Hypothesis_1)

  Conn2 <- Connections %>% mutate(Connection =paste(Hypothesis_1, "->",Hypothesis_2),Level=Level_1) %>%
                           dplyr::select(Level,Connection)

  cat("\nHypotheses to be tested \n=======================\n\n")
  print(tree,row.names=FALSE)

  cat("\nConnection structure of the hypotheses \n======================================\n\n")
  print(Conn2,row.names=FALSE)

  invisible(list(Hyp_tree=tree,Connections=Conn2))
}


#' @rdname Generic_functions
#' @export

Display <- function(object, ...) UseMethod("Display")

#' @rdname Generic_functions
#' @export

 Display.ctp <- function (object, Type = "s", arrow=FALSE, ...)
{
  if (!(Type %in% c("s","t"))) stop("\"type\" must be either \"s\" or \"t\"")
  if (!(oldClass(object) %in% c("ctp.str","ctp")))
    stop("First argument must be an object of class ctp or ctp.str")
  if(class(object)=="ctp")     tree  <- object$pvalues  %>% group_by(level) %>% arrange(desc(level))
  if(class(object)=="ctp.str") tree  <- object$hypnames %>% group_by(level) %>% arrange(desc(level))

  nHyp   <- dim(tree)[1]
  Names  <- tree$hypothesis.name
  nLev   <- tree %>% summarise(n=n()) %>% dplyr::select(n)
  pos    <- rev(nLev$n)
  mPosx  <- max(pos)

  if(class(object)=="ctp")
  {
    Parms <- object$CTPparms

    pv        <- round(tree$pvalue, 3)
    pvch      <- ifelse(pv < 0.001, "(p<0.001)", paste("(p=", pv, ")"))
    pvadj     <- round(tree$pvalue.adj, 3)
    pvadjch   <- ifelse(pvadj < 0.001, "p<0.001", paste("p=", pvadj))
    pvadjch   <- ifelse(is.na(pvadj), "", pvadj)
    Names     <- paste(Names, "\n", pvadjch, "\n", pvch, sep = "")
  }

  ### for size of boxes and text

  BoxSize  <- 0.08 - 0.005*(mPosx-2)
  BoxSize  <- max(BoxSize,0.01)
  TextSize <- ifelse(class(object)=="ctp",max(0.45,BoxSize*8),max(0.5,BoxSize*11))

  ####
  ####
  M0 <- matrix(nrow=nHyp,ncol=nHyp)
  if(mPosx<11)
  {
    BP <- ifelse(class(object)=="ctp",0.7,0.7)
    zz <- plotmat(M0, pos = pos, name = Names, curve=0,
                  lwd = 1, box.lwd = 2, cex.txt = 0.7, box.cex=TextSize,
                  box.size = BoxSize, box.type = "square", box.prop = BP,add=FALSE,shadow.size = 0,...)
  } else{
    BP <- ifelse(class(object)=="ctp",2.5,0.7)
    zz <-  plotmat(M0, pos = pos, name = Names, curve=0,
                   lwd = 1, box.lwd = 2, cex.txt = 0.7, box.cex=TextSize,
                   box.size = BoxSize, box.type = "none", box.prop = BP,add=FALSE,box.lcol = "white"
                   ,shadow.size = 0,...)
  }


  xTop <- zz$comp[,"x"]
  yTop <- zz$rect[,"ytop"]
  yBot <- zz$rect[,"ybot"]

  #### Connections ####

  if(class(object)=="ctp")     con  <- Parms$connections
  if(class(object)=="ctp.str") con  <- object$connections

  ncon <- length(con)
  Con  <- con[[1]]
  if (ncon >1)
  {
    for (i in 2:ncon) Con <- rbind(Con,con[[i]])
  }

  PosCon <- tree %>% ungroup() %>% mutate(x=xTop,yBot=yBot,yTop=yTop)

  To   <- Con %>% dplyr::select(level=levold,hyp.no=hypold) %>%
    left_join(tree,by = c("level", "hyp.no")) %>%
    rename(Hyp1 =hypothesis.name ) %>%
    left_join(PosCon,by = c("level", "hyp.no")) %>%
    rename(y=yTop)
  From   <- Con %>% dplyr::select(level=levnew,hyp.no=hypnew) %>%
    left_join(tree,by = c("level", "hyp.no")) %>%
    rename(Hyp2 =hypothesis.name ) %>%
    left_join(PosCon,by = c("level", "hyp.no")) %>%
    rename(y=yBot)


  #######################
  #######################

  for(i in 1:(dim(Con)[1]))
  {
    if (From[i,"hypothesis.name"] != To[i,"hypothesis.name"])
    {
      if(Type=="s") Straightarrow(unlist(From[i,c("x","y")]),unlist(To[i,c("x","y")]),arrow=arrow)
      if(Type=="t") Treearrow(unlist(From[i,c("x","y")]),unlist(To[i,c("x","y")]),arrow=arrow)
    }
  }
  if(class(object)=="ctp") text(0.1, 0.85, "[ ...]  null hypothesis\np=...    - adjusted\n(p= ...) - unadjusted",
                                cex = max(TextSize,0.7), adj = 0)
  invisible()
}

#' @rdname Generic_functions
#' @export

Display.ctp.str <- function (object, Type = "s", arrow=FALSE, ...)
{
  Display.ctp(object=object, Type = Type, arrow=arrow, ...)
}