Skip to content

Commit

Permalink
standardizing cohort method
Browse files Browse the repository at this point in the history 
- standardizing cohort method
  • Loading branch information
@jreps
jreps committed Aug 4, 2023
1 parent 3bb7416 commit c82addd
Show file tree
Hide file tree
Showing 64 changed files with 2,579 additions and 3,575 deletions.
8 changes: 2 additions & 6 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -31,8 +31,6 @@ export(cohortMethodCovariateBalanceServer)
export(cohortMethodCovariateBalanceViewer)
export(cohortMethodDiagnosticsSummaryServer)
export(cohortMethodDiagnosticsSummaryViewer)
export(cohortMethodForestPlotServer)
export(cohortMethodForestPlotViewer)
export(cohortMethodHelperFile)
export(cohortMethodKaplanMeierServer)
export(cohortMethodKaplanMeierViewer)
Expand All @@ -44,11 +42,9 @@ export(cohortMethodPropensityModelServer)
export(cohortMethodPropensityModelViewer)
export(cohortMethodPropensityScoreDistServer)
export(cohortMethodPropensityScoreDistViewer)
export(cohortMethodResultsTableServer)
export(cohortMethodResultsTableViewer)
export(cohortMethodResultSummaryServer)
export(cohortMethodResultSummaryViewer)
export(cohortMethodServer)
export(cohortMethodSubgroupsServer)
export(cohortMethodSubgroupsViewer)
export(cohortMethodSystematicErrorServer)
export(cohortMethodSystematicErrorViewer)
export(cohortMethodViewer)
Expand Down
237 changes: 209 additions & 28 deletions R/cohort-method-attrition.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,7 +26,7 @@
#' @export
cohortMethodAttritionViewer <- function(id) {
ns <- shiny::NS(id)

shiny::div(
shiny::plotOutput(outputId = ns("attritionPlot"), width = 600, height = 600),
shiny::uiOutput(outputId = ns("attritionPlotCaption")),
Expand All @@ -42,7 +42,6 @@ cohortMethodAttritionViewer <- function(id) {
#'
#' @param id the unique reference id for the module
#' @param selectedRow the selected row from the main results table
#' @param inputParams the selected study parameters of interest
#' @param connectionHandler the connection to the PLE results database
#' @param resultDatabaseSettings a list containing the result schema and prefixes
#'
Expand All @@ -53,62 +52,244 @@ cohortMethodAttritionViewer <- function(id) {
cohortMethodAttritionServer <- function(
id,
selectedRow,
inputParams,
connectionHandler,
resultDatabaseSettings
) {

shiny::moduleServer(
id,
function(input, output, session) {


attritionPlot <- shiny::reactive({
row <- selectedRow()
if (is.null(row)) {
return(NULL)
} else {
attrition <- getCohortMethodAttrition(
connectionHandler = connectionHandler,
resultDatabaseSettings = resultDatabaseSettings,
targetId = inputParams()$target,
comparatorId = inputParams()$comparator,
outcomeId = inputParams()$outcome,
databaseId = row$databaseId,
analysisId = row$analysisId
)
attritionPlot <- shiny::reactive({
attrition <- getCohortMethodAttrition(
connectionHandler = connectionHandler,
resultDatabaseSettings = resultDatabaseSettings,
selectedRow = selectedRow
)
if(!is.null(attrition)){
plot <- drawCohortMethodAttritionDiagram(attrition)
return(plot)
}
})

output$attritionPlot <- shiny::renderPlot({
return(attritionPlot())
} else{
return(NULL)
}
})


output$attritionPlot <- shiny::renderPlot({
return(attritionPlot())

Check warning on line 78 in R/cohort-method-attrition.R

View check run for this annotation

Codecov / codecov/patch

R/cohort-method-attrition.R#L78 

Added line #L78 was not covered by tests
})


output$downloadAttritionPlotPng <- shiny::downloadHandler(filename = "Attrition.png",
contentType = "image/png",
content = function(file) {
ggplot2::ggsave(file, plot = attritionPlot(), width = 6, height = 7, dpi = 400)

Check warning on line 85 in R/cohort-method-attrition.R

View check run for this annotation

Codecov / codecov/patch

R/cohort-method-attrition.R#L85 

Added line #L85 was not covered by tests
})


output$downloadAttritionPlotPdf <- shiny::downloadHandler(filename = "Attrition.pdf",
contentType = "application/pdf",
content = function(file) {
ggplot2::ggsave(file = file, plot = attritionPlot(), width = 6, height = 7)

Check warning on line 92 in R/cohort-method-attrition.R

View check run for this annotation

Codecov / codecov/patch

R/cohort-method-attrition.R#L92 

Added line #L92 was not covered by tests
})

output$attritionPlotCaption <- shiny::renderUI({
row <- selectedRow()
if (is.null(row)) {
if (is.null(selectedRow()$target)) {
return(NULL)

Check warning on line 97 in R/cohort-method-attrition.R

View check run for this annotation

Codecov / codecov/patch

R/cohort-method-attrition.R#L96-L97 

Added lines #L96 - L97 were not covered by tests
} else {
text <- "<strong>Figure 1.</strong> Attrition diagram, showing the Number of subjects in the target (<em>%s</em>) and
comparator (<em>%s</em>) group after various stages in the analysis."
return(shiny::HTML(sprintf(text, inputParams()$target, inputParams()$comparator)))
return(shiny::HTML(sprintf(text, selectedRow()$target, selectedRow()$comparator)))

Check warning on line 101 in R/cohort-method-attrition.R

View check run for this annotation

Codecov / codecov/patch

R/cohort-method-attrition.R#L99-L101 

Added lines #L99 - L101 were not covered by tests
}
})

}
)
}


getCohortMethodAttrition <- function(
connectionHandler,
resultDatabaseSettings,
selectedRow
) {

if(is.null(selectedRow()$targetId)){
return(NULL)
}

sql <- "
SELECT cmat.*
FROM
@schema.@cm_table_prefixattrition cmat
WHERE
cmat.target_id = @target_id
AND cmat.comparator_id = @comparator_id
AND cmat.outcome_id = @outcome_id
AND cmat.analysis_id = @analysis_id
AND cmat.database_id = '@database_id';
"
result <- connectionHandler$queryDb(
sql = sql,
schema = resultDatabaseSettings$schema,
cm_table_prefix = resultDatabaseSettings$cmTablePrefix,
#database_table = resultDatabaseSettings$databaseTable,
target_id = selectedRow()$targetId,
comparator_id = selectedRow()$comparatorId,
outcome_id = selectedRow()$outcomeId,
analysis_id = selectedRow()$analysisId,
database_id = selectedRow()$databaseId
)
targetAttrition <- result[result$exposureId == selectedRow()$targetId, ]
comparatorAttrition <- result[result$exposureId == selectedRow()$comparatorId, ]
colnames(targetAttrition)[colnames(targetAttrition) == "subjects"] <- "targetPersons"
targetAttrition$exposureId <- NULL
colnames(comparatorAttrition)[colnames(comparatorAttrition) == "subjects"] <- "comparatorPersons"
comparatorAttrition$exposureId <- NULL
result <- merge(targetAttrition, comparatorAttrition)
result <- result[order(result$sequenceNumber), ]

return(result)
}




drawCohortMethodAttritionDiagram <- function(
attrition,
targetLabel = "Target",
comparatorLabel = "Comparator"
) {
addStep <- function(data, attrition, row) {
label <- paste(strwrap(as.character(attrition$description[row]), width = 30), collapse = "\n")
data$leftBoxText[length(data$leftBoxText) + 1] <- label
data$rightBoxText[length(data$rightBoxText) + 1] <- paste(targetLabel,
": n = ",
data$currentTarget - attrition$targetPersons[row],
"\n",
comparatorLabel,
": n = ",
data$currentComparator - attrition$comparatorPersons[row],
sep = "")
data$currentTarget <- attrition$targetPersons[row]
data$currentComparator <- attrition$comparatorPersons[row]
return(data)
}
data <- list(leftBoxText = c(paste("Exposed:\n",
targetLabel,
": n = ",
attrition$targetPersons[1],
"\n",
comparatorLabel,
": n = ",
attrition$comparatorPersons[1],
sep = "")), rightBoxText = c(""), currentTarget = attrition$targetPersons[1], currentComparator = attrition$comparatorPersons[1])
for (i in 2:nrow(attrition)) {
data <- addStep(data, attrition, i)
}


data$leftBoxText[length(data$leftBoxText) + 1] <- paste("Study population:\n",
targetLabel,
": n = ",
data$currentTarget,
"\n",
comparatorLabel,
": n = ",
data$currentComparator,
sep = "")
leftBoxText <- data$leftBoxText
rightBoxText <- data$rightBoxText
nSteps <- length(leftBoxText)

boxHeight <- (1/nSteps) - 0.03
boxWidth <- 0.45
shadowOffset <- 0.01
arrowLength <- 0.01
x <- function(x) {
return(0.25 + ((x - 1)/2))
}
y <- function(y) {
return(1 - (y - 0.5) * (1/nSteps))
}

downArrow <- function(p, x1, y1, x2, y2) {
p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x1, y = y1, xend = x2, yend = y2))
p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2,
y = y2,
xend = x2 + arrowLength,
yend = y2 + arrowLength))
p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2,
y = y2,
xend = x2 - arrowLength,
yend = y2 + arrowLength))
return(p)
}
rightArrow <- function(p, x1, y1, x2, y2) {
p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x1, y = y1, xend = x2, yend = y2))
p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2,
y = y2,
xend = x2 - arrowLength,
yend = y2 + arrowLength))
p <- p + ggplot2::geom_segment(ggplot2::aes_string(x = x2,
y = y2,
xend = x2 - arrowLength,
yend = y2 - arrowLength))
return(p)
}
box <- function(p, x, y) {
p <- p + ggplot2::geom_rect(ggplot2::aes_string(xmin = x - (boxWidth/2) + shadowOffset,
ymin = y - (boxHeight/2) - shadowOffset,
xmax = x + (boxWidth/2) + shadowOffset,
ymax = y + (boxHeight/2) - shadowOffset), fill = grDevices::rgb(0,
0,
0,
alpha = 0.2))
p <- p + ggplot2::geom_rect(ggplot2::aes_string(xmin = x - (boxWidth/2),
ymin = y - (boxHeight/2),
xmax = x + (boxWidth/2),
ymax = y + (boxHeight/2)), fill = grDevices::rgb(0.94,
0.94,
0.94), color = "black")
return(p)
}
label <- function(p, x, y, text, hjust = 0) {
p <- p + ggplot2::geom_text(ggplot2::aes_string(x = x, y = y, label = paste("\"", substring(text,1,40), "\"",
sep = "")),
hjust = hjust,
size = 3.7)
return(p)
}

p <- ggplot2::ggplot()
for (i in 2:nSteps - 1) {
p <- downArrow(p, x(1), y(i) - (boxHeight/2), x(1), y(i + 1) + (boxHeight/2))
p <- label(p, x(1) + 0.02, y(i + 0.5), "Y")
}
for (i in 2:(nSteps - 1)) {
p <- rightArrow(p, x(1) + boxWidth/2, y(i), x(2) - boxWidth/2, y(i))
p <- label(p, x(1.5), y(i) - 0.02, "N", 0.5)
}
for (i in 1:nSteps) {
p <- box(p, x(1), y(i))
}
for (i in 2:(nSteps - 1)) {
p <- box(p, x(2), y(i))
}
for (i in 1:nSteps) {
p <- label(p, x(1) - boxWidth/2 + 0.02, y(i), text = leftBoxText[i])
}
for (i in 2:(nSteps - 1)) {
p <- label(p, x(2) - boxWidth/2 + 0.02, y(i), text = rightBoxText[i])
}
p <- p + ggplot2::theme(legend.position = "none",
plot.background = ggplot2::element_blank(),
panel.grid.major = ggplot2::element_blank(),
panel.grid.minor = ggplot2::element_blank(),
panel.border = ggplot2::element_blank(),
panel.background = ggplot2::element_blank(),
axis.text = ggplot2::element_blank(),
axis.title = ggplot2::element_blank(),
axis.ticks = ggplot2::element_blank())

return(p)
}
Loading

0 comments on commit c82addd

Please sign in to comment.