Hi,
I have got this data:
mx = matrix(c(10, 40, 90, 160), nrow = 2, byrow = FALSE)
mx
datx = data.frame(mx)
dimnames(datx) = list(disease = c("YES", "NO"), sex = c("Female", "Male"))
I would like to add rows and columns with totals and percentages.
How do I do it to get a table like in the form of SPSS:
Hi, check this link.
If you put a good example of data is better for help you all the community.
There is really nothing relevant on that website.
Hi Here is the solution using kbl function in kableExtra package
#######################################
# Loading Libraries
#######################################
library(dplyr)
library(kableExtra)
#######################################
# function for percentage with decimals
#######################################
fnpercent <- function(x, digits = 2, format = "f", ...) { # Create user-defined function
paste0(formatC(x * 100, format = format, digits = digits, ...), "%")
}
#########################################
# Building temporary dataframe called df
#########################################
Category <- c("Disease",NA,NA,NA,"Disease",NA,NA,NA,"Total",NA,NA,NA)
Subcategory <- c("No",NA,NA,NA,"Yes",NA,NA,NA,NA,NA,NA,NA)
Group <- c("Count","% within Disease","% within Sex","% of Total",
"Count","% within Disease","% within Sex","% of Total",
"Count","% within Disease","% within Sex","% of Total")
df <- data.frame(Category,Subcategory,Group)
df['Female'] <- as.character()
df['Male'] <- as.character()
df['Total'] <- as.character()
#######################################
# function to update df
#######################################
fncreaterrtable <- function(mFeDiNo,mMaDiNo,mFeDiYs,mMaDiYs){
mTotline16 <- (mFeDiNo + mMaDiNo)
mTotline66 <- (mFeDiYs + mMaDiYs)
mTotline114 <- (mFeDiNo + mFeDiYs )
mTotline115 <- (mMaDiNo + mMaDiYs)
mTotline116 <- (mTotline114 + mTotline115)
df[1,4] <<- mFeDiNo
df[1,5] <<- mMaDiNo
df[1,6] <<- mTotline16
df[5,4] <<- mFeDiYs
df[5,5] <<- mMaDiYs
df[5,6] <<- mTotline66
df[9,4] <<- mTotline114
df[9,5] <<- mTotline115
df[9,6] <<- mTotline116
# % of Disease
df[2,4] <<- fnpercent(mFeDiNo/mTotline16,2)
df[2,5] <<- fnpercent(mMaDiNo/mTotline16,2)
df[2,6] <<- fnpercent(mTotline16/mTotline16,2)
df[6,4] <<- fnpercent(mFeDiYs/mTotline66,2)
df[6,5] <<- fnpercent(mMaDiYs/mTotline66,2)
df[6,6] <<- fnpercent(mTotline66/mTotline66,2)
df[10,4] <<- fnpercent(mTotline114/mTotline116,2)
df[10,5] <<- fnpercent(mTotline115/mTotline116,2)
df[10,6] <<- fnpercent(mTotline116/mTotline116,2)
# % of Sex
df[3,4] <<- fnpercent(mFeDiNo/mTotline114,2)
df[3,5] <<- fnpercent(mMaDiNo/mTotline115,2)
df[3,6] <<- fnpercent(mTotline16/mTotline116,2)
df[7,4] <<- fnpercent(mFeDiYs/mTotline114,2)
df[7,5] <<- fnpercent(mMaDiYs/mTotline115,2)
df[7,6] <<- fnpercent(mTotline66/mTotline116,2)
df[11,4] <<- fnpercent(mTotline114/mTotline116,2)
df[11,5] <<- fnpercent(mTotline115/mTotline116,2)
df[11,6] <<- fnpercent(mTotline116/mTotline116,2)
# % of Total
df[4,4] <<- fnpercent(mFeDiNo/mTotline116,2)
df[4,5] <<- fnpercent(mMaDiNo/mTotline116,2)
df[4,6] <<- fnpercent(mTotline16/mTotline116,2)
df[8,4] <<- fnpercent(mFeDiYs/mTotline116,2)
df[8,5] <<- fnpercent(mMaDiYs/mTotline116,2)
df[8,6] <<- fnpercent(mTotline66/mTotline116,2)
df[12,4] <<- fnpercent(mTotline114/mTotline116,2)
df[12,5] <<- fnpercent(mTotline115/mTotline116,2)
df[12,6] <<- fnpercent(mTotline116/mTotline116,2)
df <<- sapply(df, as.character) # Convert all columns to character
df[is.na(df)] <<- "" # Replace NA with blank
fngeneratekbltbl()
}
#####################################################
# function to generate kbl table
#####################################################
fngeneratekbltbl <- function(){
df %>%
kbl(align = "lllccc",caption =paste('<h4><STRONG><CENTER>','Disease * Sex Crosstabulation', '</CENTER></STRONG><h6>'),
escape=T, col.names = c("", "", "", "Female", "Male", "Total")) %>%
kable_paper(c("striped"),full_width = F) %>%
column_spec(1, bold = T, background = "#91D1C233",border_left = T) %>%
column_spec(1,width = "6em", border_right = T) %>%
column_spec(2,width = "4em", border_right = T) %>%
column_spec(3,width = "8em", border_right = T) %>%
column_spec(c(4,5,6), width = "4em") %>%
column_spec(c(4,5,6), italic = T,border_right = T,width = "5em") %>%
row_spec(0, bold = T, font_size = 13, extra_css = "border-bottom: 1px solid;") %>%
row_spec(c(4,8), extra_css = "border-bottom: 1px solid;") %>%
add_header_above(c(" " = 3, "Sex" = 2, " " = 1),
bold = T,extra_css ="border-bottom: 1px solid;") %>%
kable_classic_2()
}
#####################################################
# finally call function for contingency table
#####################################################
fncreaterrtable(90,160,10,40)
Thank you very much indeed for solution @ganapap1 and your tedious and hard work and taking the time to help me. This is fantastic and I really appreciate it.
One question, is this table easily extendable to 2x3 or 3x3 contingency table ?
Hi Andrzej, I am happy that you find it helpful. Yes, it is extendable to any combination of contingency tables as the kbl function work with a dataframe. you only have to suitably modify code by adding additional columns and rows and modify column numbers in kbl function.
let me check whether we can automate the entire process of column naming and row naming. so that you need not hard code them like 'Disease' or 'Sex'
Please do, as I extensively work with SPSS it would be very helpful, thank you again.
Hi Andrzej, finally done, fully automated for 2x2, 2x3, 3x2, and 3x3 contingency tables
Please note column and row headers having dark green backgrounds are all fully editable, it will reflect immediately on the Table. lengthier heading will be wrapped automatically. Fully automated, it has come very well , hope works for you as well
#######################################
# Loading Libraries
#######################################
library(shiny)
library(shinydashboard)
library(shinyjs)
library(stringr)
library(shinyWidgets)
library(dplyr)
library(kableExtra)
#######################################
# function for percentage with decimals
#######################################
fnpercent <- function(x, digits = 2, format = "f", ...) { # Create user-defined function
paste0(formatC(x * 100, format = format, digits = digits, ...), "%")
}
#######################################
# Dashboard UI
#######################################
ui <- fluidPage(
# Coloring textInput box #where you got:https://stackoverflow.com/questions/47478123/how-to-change-background-color-for-textInput-in-r-shiny
tags$head(tags$style(HTML('
#mRow0name, #mRow1name, #mRow2name, #mRow3name, #mRow4name,#mcol1name,#mcol2name,
#mcol3name,#mcol4name{
color:white; font-size:14px;
font-family: Calibri;
font-weight: normal;
background-color: #2f4f4f !important;
border: 2px double black;border-style:solid;
height: 32px;
overflow-y:none;
border: none;
}'))),
column(
width = 12,
align='center',
div(style = "margin-top:20px"),
HTML(paste('<h3><b>','Contingency Table Automated','</b><h5>')),
column(style = "border: 2px double red;height: 500px;overflow-y: auto;",
width = 5,
align = 'center',
div(style = "margin-top:20px"),
selectInput(
inputId = "mTableTypeChk",
label = 'Select Table Type',
choices = c('2x2','2x3','3x2','3x3'),
selected = '2x2',
width = '150px',
multiple = F
),
textInput(inputId = 'mgrptitle',label = "Group Header eg 'Gender'",value = 'Gender'),
HTML('Data for Contingency Table'),
splitLayout(cellWidths = c('25%','18%','18%','18%','20%'),
textInput(inputId = 'mRow0name',label = NULL,value = 'Table'),
textInput(inputId = 'mcol1name',label = NULL,value = 'Column1'),
textInput(inputId = 'mcol2name',label = NULL,value = 'Column2'),
textInput(inputId = 'mcol3name',label = NULL,value = 'Column3'),
textInput(inputId = 'mcol4name',label = NULL,value = 'Total')
),
div(style = "margin-top:-15px"),
splitLayout(cellWidths = c('25%','18%','18%','18%','20%'),
textInput(inputId = 'mRow1name',label = NULL,value = 'Row1'),
shinyWidgets::autonumericInput(inputId = "mValC11",label = NULL,value = 90,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC12",label = NULL,value = 160,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC13",label = NULL,value = 90,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC14",label = NULL,value = 90,digitGroupSeparator = ",", decimalPlaces = 0)
),
div(style = "margin-top:-15px"),
splitLayout(cellWidths = c('25%','18%','18%','18%','20%'),
textInput(inputId = 'mRow2name',label = NULL,value = 'Row2'),
shinyWidgets::autonumericInput(inputId = "mValC21",label = NULL,value = 10,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC22",label = NULL,value = 40,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC23",label = NULL,value = 10,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC24",label = NULL,value = 10,digitGroupSeparator = ",", decimalPlaces = 0)
),
div(style = "margin-top:-15px"),
splitLayout(cellWidths = c('25%','18%','18%','18%','20%'),
textInput(inputId = 'mRow3name',label = NULL,value = 'Row3'),
shinyWidgets::autonumericInput(inputId = "mValC31",label = NULL,value = 10,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC32",label = NULL,value = 40,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC33",label = NULL,value = 10,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC34",label = NULL,value = 10,digitGroupSeparator = ",", decimalPlaces = 0)
),
div(style = "margin-top:-15px"),
splitLayout(cellWidths = c('25%','18%','18%','18%','20%'),
textInput(inputId = 'mRow4name',label = NULL,value = 'Total'),
shinyWidgets::autonumericInput(inputId = "mValC41",label = NULL,value = 10,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC42",label = NULL,value = 40,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC43",label = NULL,value = 10,digitGroupSeparator = ",", decimalPlaces = 0),
shinyWidgets::autonumericInput(inputId = "mValC44",label = NULL,value = 10,digitGroupSeparator = ",", decimalPlaces = 0)
)
),
column(style = "border: 2px double red;height: 500px;overflow-y: auto;",
width = 7,
align = 'center',
htmlOutput('mshowmatrixtbl')
)
) #fluidrow closure
)
server <- function(input, output, session) {
#####################################################
# finally call function for contingency table
#####################################################
observeEvent(
c(input$mTableTypeChk,
input$mgrptitle,
input$mRow1name,
input$mRow2name,
input$mRow3name,
input$mRow4name,
input$mValC11,
input$mValC12,
input$mValC13,
input$mValC21,
input$mValC22,
input$mValC23,
input$mValC31,
input$mValC32,
input$mValC33,
input$mValC14,
input$mValC24,
input$mValC34,
input$mValC41,
input$mValC42,
input$mValC43,
input$mValC44),{
req(input$mgrptitle)
req(input$mValC11)
req(input$mValC12)
req(input$mValC13)
req(input$mValC21)
req(input$mValC22)
req(input$mValC23)
req(input$mValC31)
req(input$mValC32)
req(input$mValC33)
observeEvent(input$mTableTypeChk,{
if(input$mTableTypeChk=='2x2'){
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC13',value = 0)
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC23',value = 0)
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC33',value = 0)
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC31',value = 0)
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC32',value = 0)
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC33',value = 0)
}else if(input$mTableTypeChk=='2x3'){
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC31',value = 0)
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC32',value = 0)
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC33',value = 0)
}else if(input$mTableTypeChk=='3x2'){
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC13',value = 0)
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC23',value = 0)
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC33',value = 0)
}
})
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC14',value = (input$mValC11+input$mValC12+input$mValC13))
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC24',value = (input$mValC21+input$mValC22+input$mValC23))
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC34',value = (input$mValC31+input$mValC32+input$mValC33))
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC41',value = (input$mValC11+input$mValC21+input$mValC31))
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC42',value = (input$mValC12+input$mValC22+input$mValC32))
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC43',value = (input$mValC13+input$mValC23+input$mValC33))
shinyWidgets::updateAutonumericInput(session,inputId = 'mValC44',value = (input$mValC11+input$mValC21+input$mValC31+input$mValC12+input$mValC22+input$mValC32+input$mValC13+input$mValC23+input$mValC33))
df <- fnCreateTemporyTbl(mRow1name= input$mRow1name,mRow2name= input$mRow2name,mRow3name= input$mRow3name,mRow4name= input$mRow4name,mgrptitle= input$mgrptitle,mcol1name= input$mcol1name,mcol2name= input$mcol2name,mcol3name= input$mcol3name)
df <- data.frame(fnUpdateTemporyTbl(
df=df,
mValC11 = input$mValC11,mValC12 = input$mValC12,mValC13 = input$mValC13,
mValC21 = input$mValC21,mValC22 = input$mValC22,mValC23 = input$mValC23,
mValC31 = input$mValC31,mValC32 = input$mValC32,mValC33 = input$mValC33))
#########################################################################
# depending on your Contingency table type whether2x2 or 2x3 or 3x2, 3x3
# This code will delete unwanted coumn and rows as NA
# and then next two lines will delete ALL NA rows and ALL NA columns
#########################################################################
if(input$mTableTypeChk=='2x2'){
df[c(9:12),] <- NA
df[,5] <- NA
}else if(input$mTableTypeChk=='2x3'){
df[c(9:12),] <- NA
}else if(input$mTableTypeChk=='3x2'){
df[,5] <- NA
}
df <-df[rowSums(is.na(df)) != ncol(df), ] # Drop empty rows
df <- df[ , colSums(is.na(df)) != nrow(df)] # Drop empty columns
output$mshowmatrixtbl <- renderUI({
if(substr(input$mTableTypeChk,3,3)=='2'){
HTML(fnGenerateKblTbl2columns(df=df,mRow1name= input$mRow1name, mcol1name= input$mcol1name,mcol2name= input$mcol2name,mcol4name= input$mcol4name,mgrptitle= input$mgrptitle))
}else{
HTML(fnGenerateKblTbl3columns(df=df,mRow1name= input$mRow1name, mcol1name= input$mcol1name,mcol2name= input$mcol2name,mcol3name= input$mcol3name,mcol4name= input$mcol4name,mgrptitle= input$mgrptitle))
}
})
})
#########################################
# Building temporary dataframe called df
#########################################
fnCreateTemporyTbl <- function(mRow1name,mRow2name,mRow3name,mRow4name,mgrptitle,mcol1name,mcol2name,mcol3name){
Category <- c(mRow1name,NA,NA,NA,mRow2name,NA,NA,NA,mRow3name,NA,NA,NA,mRow4name,NA,NA,NA)
Subcategory <- c("Count",paste(" % within",mRow1name),paste("% within",mgrptitle),"% of Total",
"Count",paste("% within",mRow2name),paste("% within",mgrptitle),"% of Total",
"Count",paste("% within",mRow3name),paste("% within",mgrptitle),"% of Total",
"Count",paste("% within",'Total'),paste("% within",mgrptitle),"% of Total")
df <- data.frame(Category,Subcategory)
df[mcol1name] <- as.character()
df[mcol2name] <- as.character()
df[mcol3name] <- as.character()
df['Total'] <- as.character()
return(df)
}
#######################################
# function to update df
#######################################
fnUpdateTemporyTbl <- function(df,mValC11,mValC12,mValC13,mValC21,mValC22,mValC23,mValC31,mValC32,mValC33){
mTotline16 <- (mValC11 + mValC12 + mValC13)
mTotline56 <- (mValC21 + mValC22 + mValC23)
mTotline96 <- (mValC31 + mValC32 + mValC33)
mTotline133 <- (mValC11 + mValC21 + mValC31)
mTotline134 <- (mValC12 + mValC22 + mValC32)
mTotline135 <- (mValC13 + mValC23 + mValC33)
mTotline136 <- (mTotline133 + mTotline134 + mTotline135)
df[1,3] <- mValC11
df[1,4] <- mValC12
df[1,5] <- mValC13
df[1,6] <- mTotline16
df[5,3] <- mValC21
df[5,4] <- mValC22
df[5,5] <- mValC23
df[5,6] <- mTotline56
df[9,3] <- mValC31
df[9,4] <- mValC32
df[9,5] <- mValC33
df[9,6] <- mTotline96
df[13,3] <- mTotline133
df[13,4] <- mTotline134
df[13,5] <- mTotline135
df[13,6] <- mTotline136
# % of Disease
df[2,3] <- fnpercent(mValC11/mTotline16,2)
df[2,4] <- fnpercent(mValC12/mTotline16,2)
df[2,5] <- fnpercent(mValC13/mTotline16,2)
df[2,6] <- fnpercent(mTotline16/mTotline16,2)
df[6,3] <- fnpercent(mValC21/mTotline56,2)
df[6,4] <- fnpercent(mValC22/mTotline56,2)
df[6,5] <- fnpercent(mValC23/mTotline56,2)
df[6,6] <- fnpercent(mTotline56/mTotline56,2)
df[10,3] <- fnpercent(mValC31/mTotline96,2)
df[10,4] <- fnpercent(mValC32/mTotline96,2)
df[10,5] <- fnpercent(mValC33/mTotline96,2)
df[10,6] <- fnpercent(mTotline96/mTotline96,2)
df[14,3] <- fnpercent(mTotline133/mTotline136,2)
df[14,4] <- fnpercent(mTotline134/mTotline136,2)
df[14,5] <- fnpercent(mTotline135/mTotline136,2)
df[14,6] <- fnpercent(mTotline136/mTotline136,2)
# % of Sex
df[3,3] <- fnpercent(mValC11/mTotline133,2)
df[3,4] <- fnpercent(mValC12/mTotline134,2)
df[3,5] <- fnpercent(mValC13/mTotline135,2)
df[3,6] <- fnpercent(mTotline16/mTotline136,2)
df[7,3] <- fnpercent(mValC21/mTotline133,2)
df[7,4] <- fnpercent(mValC22/mTotline134,2)
df[7,5] <- fnpercent(mValC23/mTotline135,2)
df[7,6] <- fnpercent(mTotline56/mTotline136,2)
df[11,3] <- fnpercent(mValC31/mTotline133,2)
df[11,4] <- fnpercent(mValC32/mTotline134,2)
df[11,5] <- fnpercent(mValC33/mTotline135,2)
df[11,6] <- fnpercent(mTotline96/mTotline136,2)
df[15,3] <- fnpercent(mTotline133/mTotline136,2)
df[15,4] <- fnpercent(mTotline134/mTotline136,2)
df[15,5] <- fnpercent(mTotline135/mTotline136,2)
df[15,6] <- fnpercent(mTotline136/mTotline136,2)
# % of Total
df[4,3] <- fnpercent(mValC11/mTotline136,2)
df[4,4] <- fnpercent(mValC12/mTotline136,2)
df[4,5] <- fnpercent(mValC13/mTotline136,2)
df[4,6] <- fnpercent(mTotline16/mTotline136,2)
df[8,3] <- fnpercent(mValC21/mTotline136,2)
df[8,4] <- fnpercent(mValC22/mTotline136,2)
df[8,5] <- fnpercent(mValC23/mTotline136,2)
df[8,6] <- fnpercent(mTotline56/mTotline136,2)
df[12,3] <- fnpercent(mValC31/mTotline136,2)
df[12,4] <- fnpercent(mValC32/mTotline136,2)
df[12,5] <- fnpercent(mValC33/mTotline136,2)
df[12,6] <- fnpercent(mTotline96/mTotline136,2)
df[16,3] <- fnpercent(mTotline133/mTotline136,2)
df[16,4] <- fnpercent(mTotline134/mTotline136,2)
df[16,5] <- fnpercent(mTotline135/mTotline136,2)
df[16,6] <- fnpercent(mTotline136/mTotline136,2)
df <- sapply(df, as.character) # Convert all columns to character
df[is.na(df)] <- "" # Replace NA with blank
return(df)
}
#####################################################
# function to generate kbl table
#####################################################
our_strwrap <- function(x) lapply(strwrap(x, width = 15, simplify= FALSE), paste, collapse = "\n")
fnGenerateKblTbl2columns <- function(df,mRow1name,mcol1name,mcol2name,mcol4name,mgrptitle){
req(input$mgrptitle)
# Set a Title for the table
mtitle <- paste(mRow1name," * ",mgrptitle, 'Crosstabulation')
mtitle <- paste('<h4><STRONG><CENTER>',mtitle, '</CENTER></STRONG><h5>')
# Set a named vector for dynamic header
myGrpHeader <- c(" " = 2, mgrptitle = 2, " " = 1) #where you got this: https://stackoverflow.com/questions/45206908/kableextra-dynamic-add-header-above-labeling
# set vector names
names(myGrpHeader) <- c(" ", mgrptitle," ")
mBorderLineRow <- c(4,8)
if(substr(input$mTableTypeChk,1,1)=='3'){
mBorderLineRow <- c(mBorderLineRow,12)
}
n <- nrow(df)
#where you got this https://stackoverflow.com/questions/70871438/creating-horizontal-lines-after-each-collapsed-row-in-kableextra-table
df %>%
kbl(align = "llcccc",caption =HTML(mtitle),linesep = "\\addlinespace",row.names=FALSE,
escape=T, col.names = c("", "", our_strwrap(mcol1name),our_strwrap(mcol2name),our_strwrap(mcol4name))) %>%
kable_paper(c("striped"),full_width = F) %>%
column_spec(1, bold = T, background = "#91D1C233",border_left = T) %>%
column_spec(1,width = "8em", border_right = T) %>%
column_spec(2,width = "10em", border_right = T) %>%
column_spec(c(3,4,5), width = "8em") %>%
column_spec(c(3,4,5), italic = T,border_right = T,width = "8em") %>%
row_spec(0, bold = T, font_size = 13, extra_css = "border-bottom: 1px solid;") %>%
row_spec(mBorderLineRow, extra_css = "border-bottom: 1px solid;") %>%
row_spec(c(n), extra_css = "border-bottom: 1px solid;") %>%
# kable_styling(bootstrap_options = "striped") %>%
add_header_above(header = myGrpHeader,
bold = T,extra_css ="border-bottom: 1px solid;") %>%
kable_classic(lightable_options = "basic",
html_font = "\"Arial Narrow\", \"Source Sans Pro\", sans-serif")
}
fnGenerateKblTbl3columns <- function(df,mRow1name,mcol1name,mcol2name,mcol3name,mcol4name,mgrptitle){
req(input$mgrptitle)
# Set a Title for the table
mtitle <- paste(mRow1name," * ",mgrptitle, 'Crosstabulation')
mtitle <- paste('<h4><STRONG><CENTER>',mtitle, '</CENTER></STRONG><h5>')
# Set a named vector for dynamic header
myGrpHeader <- c(" " = 2, mgrptitle = 3, " " = 1) #where you got this: https://stackoverflow.com/questions/45206908/kableextra-dynamic-add-header-above-labeling
# set vector names
names(myGrpHeader) <- c(" ", mgrptitle," ")
mBorderLineRow <- c(4,8)
if(substr(input$mTableTypeChk,1,1)=='3'){
mBorderLineRow <- c(mBorderLineRow,12)
}
n <- nrow(df)
#where you got this https://stackoverflow.com/questions/70871438/creating-horizontal-lines-after-each-collapsed-row-in-kableextra-table
df %>%
kbl(align = "llcccc",caption =HTML(mtitle),linesep = "\\addlinespace",row.names=FALSE,
escape=T, col.names = c("", "", mcol1name,mcol2name,mcol3name,our_strwrap(mcol4name))) %>%
kable_paper(c("striped"),full_width = F) %>%
column_spec(1, bold = T, background = "#91D1C233",border_left = T) %>%
column_spec(1,width = "8em", border_right = T) %>%
column_spec(2,width = "10em", border_right = T) %>%
column_spec(c(3,4,5,6), width = "8em") %>%
column_spec(c(3,4,5,6), italic = T,border_right = T,width = "8em") %>%
row_spec(0, bold = T, font_size = 13, extra_css = "border-bottom: 1px solid;") %>%
row_spec(mBorderLineRow, extra_css = "border-bottom: 1px solid;") %>%
row_spec(c(n), extra_css = "border-bottom: 1px solid;") %>%
# kable_styling(bootstrap_options = "striped") %>%
add_header_above(header = myGrpHeader,
bold = T,extra_css ="border-bottom: 1px solid;") %>%
kable_classic(lightable_options = "basic",
html_font = "\"Arial Narrow\", \"Source Sans Pro\", sans-serif")
}
}
shinyApp(ui, server)
Hi @ganapap1,
Once again thank you very much indeed for your ecxellent solution which I understand requires lots of effort put in it and time as well.
I wish I knew how to do it myself and I admire your skills.
It helped me a lot, IMHO it should be regarder as solution of the year in this forum.
I am very grateful.
Thank you again.
Andrzej
Thanks to you for raising such an interesting question on the Forum. I am a YouTuber on R Programming - Data Science, machine learning, and statistics as well as excel macro. my YouTube Channel Name: "Happy Learning-GP". With your permission can I publish this on my YouTube Channel as a video and audio tutorial? Hope you have no objection. Further, kindly visit my channel, you have a lot, especially on medical statistics, everything is like a package, just download and run like this solution
Of course I have no objection, glad to hear that you will publish it as a video/audio tutorial that I will watch with great pleasure and interest.
I did not use Shiny too often but now reading and learning from your solutions I found it very useful and I will treat that as an opportunity to start a new chapter in my R journey.
Once again thank you and all the best to you,
Andrzej
This topic was automatically closed 7 days after the last reply. New replies are no longer allowed.
If you have a query related to it or one of the replies, start a new topic and refer back with a link.