R/regroup.desc.R
In jfrancoiscollin/ClinReport: Statistical Reporting for Scientific Publications, Epidemiological Studies and Clinical Trials
Defines functions
regroup.desc
regroup
Documented in
regroup
regroup.desc
# TODO: Add comment
#
# Author: jfcollin
###############################################################################
#' Regroup two descriptive tables into one
#'
#' @param x A desc object
#' @param y A desc object
#' @param rbind.label Character. The label for rbind column header
#' @param y.label Character. The label for the response (included in the title)
#' @param ... Other parameters
#'
#'
#' @description
#' \code{regroup}
#' regroup two descriptive tables (qualitative or quantitative) into one
#'
#' @details
#'
#' Regroup a quantitative table and a qualitative table, is only possible if there is one and only one explicative variable.
#' So it works if and only if \code{x1} argument in \code{x} and \code{y} objects are not NULL, are the same
#' and if \code{x2} argument is NULL in both \code{x} and \code{y} objects.
#'
#' The function takes the y.label argument of object \code{x} and \code{y} respectively
#' as label for the levels of the new column created under the name of rbind.label (see example below)
#'
#' It's also possible to regroup two quantitative tables, in this case it's possible if there is one or
#' two explicative variables.
#'
#' For now it's not possible to regroup two qualitative tables.
#'
#' @return
#' A desc object corresponding to a table of statistics.
#'
#' @seealso \code{\link{report.quali}} \code{\link{report.quanti}} \code{\link{report.doc}} \code{\link{desc}}
#'
#' @examples
#'
#' data(datafake)
#'
#' # Example with a qualitative and a quantitative tables
#' #The argument y.label is stored in the desc object and
#' # only used after by the regroup function
#'
#'tab1=report.quanti(data=datafake,y="y_numeric",
#' x1="GROUP",subjid="SUBJID",y.label="Y numeric")
#'
#'tab2=report.quali(data=datafake,y="y_logistic",
#' x1="GROUP",subjid="SUBJID",y.label="Y logistic")
#'
#'regroup(tab1,tab2,rbind.label="The label of your choice")
#'
#'
#' # Example with 2 quantitative tables
#'
#'tab1=report.quanti(data=datafake,y="y_numeric",
#' x1="GROUP",subjid="SUBJID",y.label="Y numeric")
#'
#' datafake$y_numeric2=rnorm(length(datafake$y_numeric))
#'
#'tab2=report.quanti(data=datafake,y="y_numeric2",
#' x1="GROUP",subjid="SUBJID",y.label="Y Numeric 2")
#'
#'regroup(tab1,tab2,rbind.label="The label of your choice")
#'
#' @rdname regroup
#'
#' @export
regroup <- function(x,y,...)
{
UseMethod("regroup")
}
#' @rdname regroup
#'
#' @export
regroup.desc=function(x,y,rbind.label="Response",y.label="",...)
{
if(x$type.desc=="lsmeans") stop("Binding impossible for now for ls means table")
if(y$type.desc=="lsmeans") stop("Binding impossible for now for ls means table")
if(x$regrouped==T & y$regrouped==F)
{
if(x$type.desc=="quali_quanti")
{
y$output$rbind.label=y$y.label
colnames(y$output)[colnames(y$output)=="rbind.label"]=x$rbind.label
rbind.label=x$rbind.label
}
if(x$type.desc=="quali")
{
y$output$rbind.label=y$y.label
colnames(y$output)[colnames(y$output)=="rbind.label"]=x$rbind.label
rbind.label=x$rbind.label
}
if(x$type.desc=="quanti")
{
y$output$rbind.label=y$y.label
colnames(y$output)[colnames(y$output)=="rbind.label"]=x$rbind.label
rbind.label=x$rbind.label
}
}
if(x$regrouped==F & y$regrouped==T)
{
if(y$type.desc=="quali_quanti")
{
x$output$rbind.label=x$y.label
colnames(x$output)[colnames(x$output)=="rbind.label"]=y$rbind.label
rbind.label=y$rbind.label
}
}
out.x=droplevels(x$output)
out.y=droplevels(y$output)
# Mixed binding (quali-quanti or quanti-quali)
if(x$type.desc!=y$type.desc)
{
if(!is.null(x$x2) | !is.null(y$x2)) stop("Binding impossible with x2 argument not NULL")
#check
if(x$total!=y$total) stop("Different Total argument: binding impossible")
if(is.null(y$x1)) stop("x1 argument cannot be NULL: binding impossible")
if(is.null(x$x1)) stop("x1 argument cannot be NULL: binding impossible")
if(x$x1!=y$x1) stop("Different x1 argument: binding impossible")
if(!is.null(x$subjid) & !is.null(y$subjid))
{
if(x$subjid!=y$subjid) stop("Different subjid argument: binding impossible")
}
if(is.null(x$subjid) & !is.null(y$subjid)) stop("Different subjid argument: binding impossible")
if(!is.null(x$subjid) & is.null(y$subjid)) stop("Different subjid argument: binding impossible")
if(x$type.desc=="quanti") out.x$Levels=""
if(y$type.desc=="quanti") out.y$Levels=""
if(x$regrouped==F & y$regrouped==F)
{
out.x$rbind=x$y.label
out.y$rbind=y$y.label
}
r=rbind(out.x,out.y)
if(x$type.desc=="quali") r=r[,colnames(out.x)]
if(y$type.desc=="quali") r=r[,colnames(out.y)]
if(x$regrouped==F & y$regrouped==F)
{
r=spacetable(r,"rbind")
colnames(r)[colnames(r)=="rbind"]=rbind.label
}else
{
r=droplevels(r[r[,rbind.label]!="",])
r=spacetable(r,rbind.label)
}
if(x$regrouped==F & y$regrouped==F)
{
nbcol=max(x$nbcol,y$nbcol)+1
}else
{
nbcol=max(x$nbcol,y$nbcol)
}
if(x$regrouped==F | y$regrouped==F)
{
r=r[,c(ncol(r),1:(ncol(r)-1))]
}
r=ClinReport::desc(output=r,
y=c(x$y,y$y),
total=x$total,x1=x$x1,
type.desc="quali_quanti",
at.row=rbind.label,
subjid=x$subjid,
nbcol=nbcol,
regrouped=T,
rbind.label=rbind.label,
y.label=y.label,
title=paste0("Descriptive statistics of ",y.label))
return(r)
}
if(x$type.desc=="quanti" & y$type.desc=="quanti")
{
if(x$total!=y$total) stop("Different Total argument: binding impossible")
if(is.null(y$x1)) stop("x1 argument cannot be NULL: binding impossible")
if(is.null(x$x1)) stop("x1 argument cannot be NULL: binding impossible")
if(x$x1!=y$x1) stop("Different x1 argument: binding impossible")
if(!is.null(x$subjid) & !is.null(y$subjid))
{
if(x$subjid!=y$subjid) stop("Different subjid argument: binding impossible")
}
if(is.null(x$subjid) & !is.null(y$subjid)) stop("Different subjid argument: binding impossible")
if(!is.null(x$subjid) & is.null(y$subjid)) stop("Different subjid argument: binding impossible")
nbcol=x$nbcol
r=rbind(out.x,out.y)
if(!x$regrouped & !y$regrouped)
{
if(x$y!=y$y)
{
r$rbind="lab"
r$rbind[1:nrow(out.x)]=x$y.label
r$rbind[(nrow(out.x)+1):nrow(r)]=y$y.label
colnames(r)[colnames(r)=="rbind"]=rbind.label
r=spacetable(r,rbind.label)
r=r[,c(ncol(r),1:(ncol(r)-1))]
}
}else
{
r=droplevels(r[r[,rbind.label]!="",])
r=spacetable(r,rbind.label)
}
if(x$y==y$y)
{
if(is.null(x$x2)) r=r[order(r[,x$stat.name]),]
if(!is.null(x$x2))
{
r=r[order(r[,x$x2],r[,x$stat.name]),]
if(!is.null(x$at.row))
{
r=droplevels(r[r[,x$at.row]!="",])
lev=levels(r[,x$stat.name])
r=spacetable(r,x$at.row)
r[,x$stat.name]=factor(r[,x$stat.name],levels=c(lev,""))
}
}
}
r=ClinReport::desc(output=r,
y=x$y,
total=x$total,x1=x$x1,x2=x$x2,
type.desc=x$type.desc,subjid=x$subjid,
nbcol=nbcol,
stat.name=x$stat.name,
at.row=x$at.row,
regrouped=T,
rbind.label=rbind.label,
y.label=y.label,
title=paste0("Quantitative descriptive statistics of ",y.label))
return(r)
}
if(x$type.desc=="quali" & y$type.desc=="quali")
{
if(is.null(x$x2) & is.null(y$x2))
{
if(!is.null(x$x1) & !is.null(y$x1))
{
if(!is.null(x$subjid) & !is.null(y$subjid))
{
if(x$subjid!=y$subjid) stop("Different subjid argument: binding impossible")
}
nbcol=x$nbcol
r=rbind(out.x,out.y)
if(!x$regrouped & !y$regrouped)
{
r$rbind="lab"
r$rbind[1:nrow(out.x)]=x$y.label
r$rbind[(nrow(out.x)+1):nrow(r)]=y$y.label
colnames(r)[colnames(r)=="rbind"]=rbind.label
r=spacetable(r,rbind.label)
r=r[,c(ncol(r),1:(ncol(r)-1))]
}else
{
r=droplevels(r[r[,rbind.label]!="",])
r=spacetable(r,rbind.label)
}
r=ClinReport::desc(output=r,
y=x$y,
total=x$total,x1=x$x1,x2=x$x2,
type.desc=x$type.desc,subjid=x$subjid,
nbcol=nbcol,
stat.name=x$stat.name,
at.row=x$at.row,
regrouped=T,
rbind.label=rbind.label,
y.label=y.label,
title=paste0("Qualitative descriptive statistics of ",y.label))
return(r)
}
if(is.null(x$x1) & is.null(y$x1))
{
if(!is.null(x$subjid) & !is.null(y$subjid))
{
if(x$subjid!=y$subjid) stop("Different subjid argument: binding impossible")
}
nbcol=x$nbcol
colnames(out.x)[colnames(out.x)==x$y.label]="Results"
colnames(out.y)[colnames(out.y)==y$y.label]="Results"
r=rbind(out.x,out.y)
if(!x$regrouped & !y$regrouped)
{
r$rbind="lab"
r$rbind[1:nrow(out.x)]=x$y.label
r$rbind[(nrow(out.x)+1):nrow(r)]=y$y.label
colnames(r)[colnames(r)=="rbind"]=rbind.label
r=r[,c(ncol(r),1:(ncol(r)-1))]
r=spacetable(r,rbind.label)
}else
{
r=droplevels(r[r[,rbind.label]!="",])
r=spacetable(r,rbind.label)
}
r=ClinReport::desc(output=r,
y=x$y,
total=x$total,x1=x$x1,x2=x$x2,
type.desc=x$type.desc,subjid=x$subjid,
nbcol=nbcol,
stat.name=x$stat.name,
at.row=x$at.row,
regrouped=T,
rbind.label=rbind.label,
y.label=y.label,
title=paste0("Qualitative descriptive statistics of ",y.label))
return(r)
}
}else
{
message("The regroup function doesn't work yet with two 'quali' objects with non null x2 arguments")
}
}
}
jfrancoiscollin/ClinReport documentation built on Sept. 20, 2020, 7:33 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions regroup.desc regroup
Documented in regroup regroup.desc
# TODO: Add comment
#
# Author: jfcollin
###############################################################################
#' Regroup two descriptive tables into one
#'
#' @param x A desc object
#' @param y A desc object
#' @param rbind.label Character. The label for rbind column header
#' @param y.label Character. The label for the response (included in the title)
#' @param ... Other parameters
#'
#'
#' @description
#' \code{regroup}
#' regroup two descriptive tables (qualitative or quantitative) into one
#'
#' @details
#'
#' Regroup a quantitative table and a qualitative table, is only possible if there is one and only one explicative variable.
#' So it works if and only if \code{x1} argument in \code{x} and \code{y} objects are not NULL, are the same
#' and if \code{x2} argument is NULL in both \code{x} and \code{y} objects.
#'
#' The function takes the y.label argument of object \code{x} and \code{y} respectively
#' as label for the levels of the new column created under the name of rbind.label (see example below)
#'
#' It's also possible to regroup two quantitative tables, in this case it's possible if there is one or
#' two explicative variables.
#'
#' For now it's not possible to regroup two qualitative tables.
#'
#' @return
#' A desc object corresponding to a table of statistics.
#'
#' @seealso \code{\link{report.quali}} \code{\link{report.quanti}} \code{\link{report.doc}} \code{\link{desc}}
#'
#' @examples
#'
#' data(datafake)
#'
#' # Example with a qualitative and a quantitative tables
#' #The argument y.label is stored in the desc object and
#' # only used after by the regroup function
#'
#'tab1=report.quanti(data=datafake,y="y_numeric",
#' x1="GROUP",subjid="SUBJID",y.label="Y numeric")
#'
#'tab2=report.quali(data=datafake,y="y_logistic",
#' x1="GROUP",subjid="SUBJID",y.label="Y logistic")
#'
#'regroup(tab1,tab2,rbind.label="The label of your choice")
#'
#'
#' # Example with 2 quantitative tables
#'
#'tab1=report.quanti(data=datafake,y="y_numeric",
#' x1="GROUP",subjid="SUBJID",y.label="Y numeric")
#'
#' datafake$y_numeric2=rnorm(length(datafake$y_numeric))
#'
#'tab2=report.quanti(data=datafake,y="y_numeric2",
#' x1="GROUP",subjid="SUBJID",y.label="Y Numeric 2")
#'
#'regroup(tab1,tab2,rbind.label="The label of your choice")
#'
#' @rdname regroup
#'
#' @export
regroup <- function(x,y,...)
{
UseMethod("regroup")
}
#' @rdname regroup
#'
#' @export
regroup.desc=function(x,y,rbind.label="Response",y.label="",...)
{
if(x$type.desc=="lsmeans") stop("Binding impossible for now for ls means table")
if(y$type.desc=="lsmeans") stop("Binding impossible for now for ls means table")
if(x$regrouped==T & y$regrouped==F)
{
if(x$type.desc=="quali_quanti")
{
y$output$rbind.label=y$y.label
colnames(y$output)[colnames(y$output)=="rbind.label"]=x$rbind.label
rbind.label=x$rbind.label
}
if(x$type.desc=="quali")
{
y$output$rbind.label=y$y.label
colnames(y$output)[colnames(y$output)=="rbind.label"]=x$rbind.label
rbind.label=x$rbind.label
}
if(x$type.desc=="quanti")
{
y$output$rbind.label=y$y.label
colnames(y$output)[colnames(y$output)=="rbind.label"]=x$rbind.label
rbind.label=x$rbind.label
}
}
if(x$regrouped==F & y$regrouped==T)
{
if(y$type.desc=="quali_quanti")
{
x$output$rbind.label=x$y.label
colnames(x$output)[colnames(x$output)=="rbind.label"]=y$rbind.label
rbind.label=y$rbind.label
}
}
out.x=droplevels(x$output)
out.y=droplevels(y$output)
# Mixed binding (quali-quanti or quanti-quali)
if(x$type.desc!=y$type.desc)
{
if(!is.null(x$x2) | !is.null(y$x2)) stop("Binding impossible with x2 argument not NULL")
#check
if(x$total!=y$total) stop("Different Total argument: binding impossible")
if(is.null(y$x1)) stop("x1 argument cannot be NULL: binding impossible")
if(is.null(x$x1)) stop("x1 argument cannot be NULL: binding impossible")
if(x$x1!=y$x1) stop("Different x1 argument: binding impossible")
if(!is.null(x$subjid) & !is.null(y$subjid))
{
if(x$subjid!=y$subjid) stop("Different subjid argument: binding impossible")
}
if(is.null(x$subjid) & !is.null(y$subjid)) stop("Different subjid argument: binding impossible")
if(!is.null(x$subjid) & is.null(y$subjid)) stop("Different subjid argument: binding impossible")
if(x$type.desc=="quanti") out.x$Levels=""
if(y$type.desc=="quanti") out.y$Levels=""
if(x$regrouped==F & y$regrouped==F)
{
out.x$rbind=x$y.label
out.y$rbind=y$y.label
}
r=rbind(out.x,out.y)
if(x$type.desc=="quali") r=r[,colnames(out.x)]
if(y$type.desc=="quali") r=r[,colnames(out.y)]
if(x$regrouped==F & y$regrouped==F)
{
r=spacetable(r,"rbind")
colnames(r)[colnames(r)=="rbind"]=rbind.label
}else
{
r=droplevels(r[r[,rbind.label]!="",])
r=spacetable(r,rbind.label)
}
if(x$regrouped==F & y$regrouped==F)
{
nbcol=max(x$nbcol,y$nbcol)+1
}else
{
nbcol=max(x$nbcol,y$nbcol)
}
if(x$regrouped==F | y$regrouped==F)
{
r=r[,c(ncol(r),1:(ncol(r)-1))]
}
r=ClinReport::desc(output=r,
y=c(x$y,y$y),
total=x$total,x1=x$x1,
type.desc="quali_quanti",
at.row=rbind.label,
subjid=x$subjid,
nbcol=nbcol,
regrouped=T,
rbind.label=rbind.label,
y.label=y.label,
title=paste0("Descriptive statistics of ",y.label))
return(r)
}
if(x$type.desc=="quanti" & y$type.desc=="quanti")
{
if(x$total!=y$total) stop("Different Total argument: binding impossible")
if(is.null(y$x1)) stop("x1 argument cannot be NULL: binding impossible")
if(is.null(x$x1)) stop("x1 argument cannot be NULL: binding impossible")
if(x$x1!=y$x1) stop("Different x1 argument: binding impossible")
if(!is.null(x$subjid) & !is.null(y$subjid))
{
if(x$subjid!=y$subjid) stop("Different subjid argument: binding impossible")
}
if(is.null(x$subjid) & !is.null(y$subjid)) stop("Different subjid argument: binding impossible")
if(!is.null(x$subjid) & is.null(y$subjid)) stop("Different subjid argument: binding impossible")
nbcol=x$nbcol
r=rbind(out.x,out.y)
if(!x$regrouped & !y$regrouped)
{
if(x$y!=y$y)
{
r$rbind="lab"
r$rbind[1:nrow(out.x)]=x$y.label
r$rbind[(nrow(out.x)+1):nrow(r)]=y$y.label
colnames(r)[colnames(r)=="rbind"]=rbind.label
r=spacetable(r,rbind.label)
r=r[,c(ncol(r),1:(ncol(r)-1))]
}
}else
{
r=droplevels(r[r[,rbind.label]!="",])
r=spacetable(r,rbind.label)
}
if(x$y==y$y)
{
if(is.null(x$x2)) r=r[order(r[,x$stat.name]),]
if(!is.null(x$x2))
{
r=r[order(r[,x$x2],r[,x$stat.name]),]
if(!is.null(x$at.row))
{
r=droplevels(r[r[,x$at.row]!="",])
lev=levels(r[,x$stat.name])
r=spacetable(r,x$at.row)
r[,x$stat.name]=factor(r[,x$stat.name],levels=c(lev,""))
}
}
}
r=ClinReport::desc(output=r,
y=x$y,
total=x$total,x1=x$x1,x2=x$x2,
type.desc=x$type.desc,subjid=x$subjid,
nbcol=nbcol,
stat.name=x$stat.name,
at.row=x$at.row,
regrouped=T,
rbind.label=rbind.label,
y.label=y.label,
title=paste0("Quantitative descriptive statistics of ",y.label))
return(r)
}
if(x$type.desc=="quali" & y$type.desc=="quali")
{
if(is.null(x$x2) & is.null(y$x2))
{
if(!is.null(x$x1) & !is.null(y$x1))
{
if(!is.null(x$subjid) & !is.null(y$subjid))
{
if(x$subjid!=y$subjid) stop("Different subjid argument: binding impossible")
}
nbcol=x$nbcol
r=rbind(out.x,out.y)
if(!x$regrouped & !y$regrouped)
{
r$rbind="lab"
r$rbind[1:nrow(out.x)]=x$y.label
r$rbind[(nrow(out.x)+1):nrow(r)]=y$y.label
colnames(r)[colnames(r)=="rbind"]=rbind.label
r=spacetable(r,rbind.label)
r=r[,c(ncol(r),1:(ncol(r)-1))]
}else
{
r=droplevels(r[r[,rbind.label]!="",])
r=spacetable(r,rbind.label)
}
r=ClinReport::desc(output=r,
y=x$y,
total=x$total,x1=x$x1,x2=x$x2,
type.desc=x$type.desc,subjid=x$subjid,
nbcol=nbcol,
stat.name=x$stat.name,
at.row=x$at.row,
regrouped=T,
rbind.label=rbind.label,
y.label=y.label,
title=paste0("Qualitative descriptive statistics of ",y.label))
return(r)
}
if(is.null(x$x1) & is.null(y$x1))
{
if(!is.null(x$subjid) & !is.null(y$subjid))
{
if(x$subjid!=y$subjid) stop("Different subjid argument: binding impossible")
}
nbcol=x$nbcol
colnames(out.x)[colnames(out.x)==x$y.label]="Results"
colnames(out.y)[colnames(out.y)==y$y.label]="Results"
r=rbind(out.x,out.y)
if(!x$regrouped & !y$regrouped)
{
r$rbind="lab"
r$rbind[1:nrow(out.x)]=x$y.label
r$rbind[(nrow(out.x)+1):nrow(r)]=y$y.label
colnames(r)[colnames(r)=="rbind"]=rbind.label
r=r[,c(ncol(r),1:(ncol(r)-1))]
r=spacetable(r,rbind.label)
}else
{
r=droplevels(r[r[,rbind.label]!="",])
r=spacetable(r,rbind.label)
}
r=ClinReport::desc(output=r,
y=x$y,
total=x$total,x1=x$x1,x2=x$x2,
type.desc=x$type.desc,subjid=x$subjid,
nbcol=nbcol,
stat.name=x$stat.name,
at.row=x$at.row,
regrouped=T,
rbind.label=rbind.label,
y.label=y.label,
title=paste0("Qualitative descriptive statistics of ",y.label))
return(r)
}
}else
{
message("The regroup function doesn't work yet with two 'quali' objects with non null x2 arguments")
}
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.