diff --git a/LegendBasicViewer/DataPulls.R b/LegendBasicViewer/DataPulls.R new file mode 100644 index 00000000..1a87bb3b --- /dev/null +++ b/LegendBasicViewer/DataPulls.R @@ -0,0 +1,477 @@ +getExposureName <- function(connection, exposureId) { + sql <- "SELECT exposure_name FROM single_exposure_of_interest WHERE exposure_id = @exposure_id + UNION ALL SELECT exposure_name FROM combi_exposure_of_interest WHERE exposure_id = @exposure_id" + sql <- SqlRender::renderSql(sql, exposure_id = exposureId)$sql + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + exposureName <- querySql(connection, sql) + return(exposureName[1, 1]) +} + +getExposureDescription <- function(connection, exposureId) { + sql <- "SELECT description FROM single_exposure_of_interest WHERE exposure_id = @exposure_id + UNION ALL SELECT exposure_name FROM combi_exposure_of_interest WHERE exposure_id = @exposure_id" + sql <- SqlRender::renderSql(sql, exposure_id = exposureId)$sql + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + exposureDescription <- querySql(connection, sql) + return(exposureDescription[1, 1]) +} + +getOutcomeName <- function(connection, outcomeId) { + sql <- "SELECT outcome_name FROM outcome_of_interest WHERE outcome_id = @outcome_id" + sql <- SqlRender::renderSql(sql, outcome_id = outcomeId)$sql + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + outcomeName <- querySql(connection, sql) + return(outcomeName[1, 1]) +} + +getIndications <- function(connection) { + sql <- "SELECT indication_id, indication_name FROM indication" + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + indications <- querySql(connection, sql) + colnames(indications) <- SqlRender::snakeCaseToCamelCase(colnames(indications)) + return(indications) +} + +getSubgroups <- function(connection) { + sql <- "SELECT DISTINCT interaction_covariate_id AS subgroup_id, covariate_name AS subgroup_name + FROM ( + SELECT DISTINCT interaction_covariate_id + FROM cm_interaction_result + ) ids + INNER JOIN covariate + ON interaction_covariate_id = covariate_id" + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + subgroups <- querySql(connection, sql) + colnames(subgroups) <- SqlRender::snakeCaseToCamelCase(colnames(subgroups)) + subgroups$subgroupName <- gsub("Subgroup: ", "", subgroups$subgroupName) + return(subgroups) +} + + +getExposures <- function(connection) { + sql <- "SELECT * FROM ( + SELECT exposure_id, exposure_name, indication_id FROM single_exposure_of_interest + UNION ALL SELECT exposure_id, exposure_name, indication_id FROM combi_exposure_of_interest + ) exposure + INNER JOIN exposure_group + ON exposure.exposure_id = exposure_group.exposure_id;" + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + exposures <- querySql(connection, sql) + colnames(exposures) <- SqlRender::snakeCaseToCamelCase(colnames(exposures)) + return(exposures) +} + +getOutcomes <- function(connection) { + sql <- "SELECT outcome_id, outcome_name, indication_id FROM outcome_of_interest" + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + outcomes <- querySql(connection, sql) + colnames(outcomes) <- SqlRender::snakeCaseToCamelCase(colnames(outcomes)) + return(outcomes) +} + +getAnalyses <- function(connection) { + sql <- "SELECT analysis_id, description FROM cohort_method_analysis" + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + analyses <- querySql(connection, sql) + colnames(analyses) <- SqlRender::snakeCaseToCamelCase(colnames(analyses)) + return(analyses) +} + +getDatabases <- function(connection) { + sql <- "SELECT * FROM database" + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + databases <- querySql(connection, sql) + colnames(databases) <- SqlRender::snakeCaseToCamelCase(colnames(databases)) + return(databases) +} + +getDatabaseDetails <- function(connection, databaseId) { + sql <- "SELECT * FROM database WHERE database_id = '@database_id'" + sql <- SqlRender::renderSql(sql, database_id = databaseId)$sql + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + databaseDetails <- querySql(connection, sql) + colnames(databaseDetails) <- SqlRender::snakeCaseToCamelCase(colnames(databaseDetails)) + return(databaseDetails) +} + +getTcoDbs <- function(connection, + targetIds = c(), + comparatorIds = c(), + outcomeIds = c(), + databaseIds = c(), + operator = "AND") { + sql <- "SELECT target_id, comparator_id, outcome_id, database_id FROM cohort_method_result WHERE analysis_id = 1" + parts <- c() + if (length(targetIds) != 0) { + parts <- c(parts, paste0("target_id IN (", paste(targetIds, collapse = ", "), ")")) + } + if (length(comparatorIds) != 0) { + parts <- c(parts, paste0("comparator_id IN (", paste(comparatorIds, collapse = ", "), ")")) + } + if (length(outcomeIds) != 0) { + parts <- c(parts, paste0("outcome_id IN (", paste(outcomeIds, collapse = ", "), ")")) + } + if (length(databaseIds) != 0) { + parts <- c(parts, paste0("database_id IN ('", paste(databaseIds, collapse = "', '"), "')")) + } + if (length(parts) != 0) { + if (operator == "AND") { + sql <- paste(sql, "AND", paste(parts, collapse = " AND ")) + } else { + sql <- paste(sql, "AND", paste(parts, collapse = " OR ")) + } + } + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + tcoDbs <- querySql(connection, sql) + colnames(tcoDbs) <- SqlRender::snakeCaseToCamelCase(colnames(tcoDbs)) + return(tcoDbs) +} + +getTcoDbsStrict <- function(connection, exposureIds = c(), outcomeIds = c(), databaseIds = c()) { + sql <- "SELECT target_id, comparator_id, outcome_id, database_id FROM cohort_method_result WHERE analysis_id = 1" + parts <- c() + if (length(exposureIds) != 0) { + for (exposureId in exposureIds) { + parts <- c(parts, + paste0("(target_id = ", exposureId, " OR comparator_id = ", exposureId, ")")) + } + } + if (length(outcomeIds) != 0) { + parts <- c(parts, paste0("outcome_id IN (", paste(outcomeIds, collapse = ", "), ")")) + } + if (length(databaseIds) != 0) { + parts <- c(parts, paste0("database_id IN ('", paste(databaseIds, collapse = "', '"), "')")) + } + if (length(parts) != 0) { + sql <- paste(sql, "AND", paste(parts, collapse = " AND ")) + } + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + tcoDbs <- querySql(connection, sql) + colnames(tcoDbs) <- SqlRender::snakeCaseToCamelCase(colnames(tcoDbs)) + return(tcoDbs) +} + +getMainResults <- function(connection, + targetIds = c(), + comparatorIds = c(), + outcomeIds = c(), + databaseIds = c(), + analysisIds = c(), + estimatesOnly = FALSE) { + if (estimatesOnly) { + sql <- "SELECT calibrated_log_rr, calibrated_se_log_rr, calibrated_ci_95_lb, calibrated_ci_95_ub FROM cohort_method_result" + } else { + sql <- "SELECT * FROM cohort_method_result" + } + parts <- c() + if (length(targetIds) != 0) { + parts <- c(parts, paste0("target_id IN (", paste(targetIds, collapse = ", "), ")")) + } + if (length(comparatorIds) != 0) { + parts <- c(parts, paste0("comparator_id IN (", paste(comparatorIds, collapse = ", "), ")")) + } + if (length(outcomeIds) != 0) { + parts <- c(parts, paste0("outcome_id IN (", paste(outcomeIds, collapse = ", "), ")")) + } + if (length(databaseIds) != 0) { + parts <- c(parts, paste0("database_id IN ('", paste(databaseIds, collapse = "', '"), "')")) + } + if (length(analysisIds) != 0) { + parts <- c(parts, paste0("analysis_id IN ('", paste(analysisIds, collapse = "', '"), "')")) + } + if (length(parts) != 0) { + sql <- paste(sql, "WHERE", paste(parts, collapse = " AND ")) + } + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + results <- querySql(connection, sql) + colnames(results) <- SqlRender::snakeCaseToCamelCase(colnames(results)) + return(results) +} + +getSubgroupResults <- function(connection, + targetIds = c(), + comparatorIds = c(), + outcomeIds = c(), + databaseIds = c(), + analysisIds = c(), + subgroupIds = c(), + estimatesOnly = FALSE) { + if (estimatesOnly) { + sql <- " + SELECT ci_95_lb, + ci_95_ub, + log_rrr, + se_log_rrr + FROM cm_interaction_result + " + } else { + sql <- "SELECT target_id, + comparator_id, + outcome_id, + cm_interaction_result.analysis_id, + cohort_method_analysis.description AS analysis_description, + cm_interaction_result.database_id, + interaction_covariate_id, + covariate_name AS interaction_covariate_name, + rrr, + ci_95_lb, + ci_95_ub, + p, + calibrated_p, + i_2, + log_rrr, + se_log_rrr, + target_subjects, + comparator_subjects, + target_days, + comparator_days, + target_outcomes, + comparator_outcomes + FROM cm_interaction_result + INNER JOIN covariate + ON cm_interaction_result.interaction_covariate_id = covariate.covariate_id + AND cm_interaction_result.database_id = covariate.database_id + INNER JOIN cohort_method_analysis + ON cm_interaction_result.analysis_id = cohort_method_analysis.analysis_id" + } + parts <- c() + if (length(targetIds) != 0) { + parts <- c(parts, paste0("target_id IN (", paste(targetIds, collapse = ", "), ")")) + } + if (length(comparatorIds) != 0) { + parts <- c(parts, paste0("comparator_id IN (", paste(comparatorIds, collapse = ", "), ")")) + } + if (length(outcomeIds) != 0) { + parts <- c(parts, paste0("outcome_id IN (", paste(outcomeIds, collapse = ", "), ")")) + } + if (length(databaseIds) != 0) { + parts <- c(parts, paste0("cm_interaction_result.database_id IN ('", + paste(databaseIds, collapse = "', '"), + "')")) + } + if (length(analysisIds) != 0) { + parts <- c(parts, paste0("cm_interaction_result.analysis_id IN (", paste(analysisIds, collapse = ", "), ")")) + } + if (length(subgroupIds) != 0) { + parts <- c(parts, paste0("interaction_covariate_id IN (", paste(subgroupIds, collapse = ", "), ")")) + } + + if (length(parts) != 0) { + sql <- paste(sql, "WHERE", paste(parts, collapse = " AND ")) + } + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + results <- querySql(connection, sql) + colnames(results) <- SqlRender::snakeCaseToCamelCase(colnames(results)) + return(results) +} + +getControlResults <- function(connection, targetId, comparatorId, analysisId, databaseId) { + sql <- "SELECT * + FROM cohort_method_result + INNER JOIN ( + SELECT outcome_id, + outcome_name, + CAST(1 AS FLOAT) AS effect_size + FROM negative_control_outcome + + UNION ALL + + SELECT outcome_id, + outcome_name, + effect_size + FROM positive_control_outcome + ) outcomes + ON cohort_method_result.outcome_id = outcomes.outcome_id + WHERE target_id = @target_id + AND comparator_id = @comparator_id + AND database_id = '@database_id' + AND analysis_id = @analysis_id" + sql <- SqlRender::renderSql(sql, + target_id = targetId, + comparator_id = comparatorId, + database_id = databaseId, + analysis_id = analysisId)$sql + results <- querySql(connection, sql) + colnames(results) <- SqlRender::snakeCaseToCamelCase(colnames(results)) + return(results) +} + +getCmFollowUpDist <- function(connection, + targetId, + comparatorId, + outcomeId, + databaseId, + analysisId) { + sql <- "SELECT target_min_days, + target_p10_days, + target_p25_days, + target_median_days, + target_p75_days, + target_p90_days, + target_max_days, + comparator_min_days, + comparator_p10_days, + comparator_p25_days, + comparator_median_days, + comparator_p75_days, + comparator_p90_days, + comparator_max_days + FROM cm_follow_up_dist + WHERE target_id = @target_id + AND comparator_id = @comparator_id + AND outcome_id = @outcome_id + AND database_id = '@database_id' + AND analysis_id = @analysis_id" + sql <- SqlRender::renderSql(sql, + target_id = targetId, + comparator_id = comparatorId, + outcome_id = outcomeId, + database_id = databaseId, + analysis_id = analysisId)$sql + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + followUpDist <- querySql(connection, sql) + colnames(followUpDist) <- SqlRender::snakeCaseToCamelCase(colnames(followUpDist)) + return(followUpDist) +} + +getCovariateBalance <- function(connection, + targetId, + comparatorId, + databaseId, + analysisId, + outcomeId = NULL) { + sql <- "SELECT covariate.covariate_id, covariate_name, covariate_analysis_id, + target_mean_before, + comparator_mean_before, + std_diff_before, + target_mean_after, + comparator_mean_after, + std_diff_after + FROM covariate_balance + INNER JOIN covariate + ON covariate_balance.covariate_id = covariate.covariate_id + AND covariate_balance.database_id = covariate.database_id + WHERE target_id = @target_id + AND comparator_id = @comparator_id + AND covariate.database_id = '@database_id' + AND analysis_id = @analysis_id + AND interaction_covariate_id IS NULL + {@outcome_id == \"\"} ? {AND outcome_id IS NULL} : {AND outcome_id = @outcome_id}" + sql <- SqlRender::renderSql(sql, + target_id = targetId, + comparator_id = comparatorId, + database_id = databaseId, + analysis_id = analysisId, + outcome_id = outcomeId)$sql + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + balance <- querySql(connection, sql) + colnames(balance) <- c("covariateId", + "covariateName", + "analysisId", + "beforeMatchingMeanTreated", + "beforeMatchingMeanComparator", + "beforeMatchingStdDiff", + "afterMatchingMeanTreated", + "afterMatchingMeanComparator", + "afterMatchingStdDiff") + balance$absBeforeMatchingStdDiff <- abs(balance$beforeMatchingStdDiff) + balance$absAfterMatchingStdDiff <- abs(balance$afterMatchingStdDiff) + return(balance) +} + +getPs <- function(connection, targetIds, comparatorIds, databaseId) { + sql <- "SELECT target_id, + comparator_id, + preference_score, + target_density, + comparator_density + FROM preference_score_dist + WHERE target_id IN (@target_ids) + AND comparator_id IN (@comparator_ids) + AND database_id = '@database_id'" + sql <- SqlRender::renderSql(sql, + target_ids = targetIds, + comparator_ids = comparatorIds, + database_id = databaseId)$sql + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + ps <- querySql(connection, sql) + colnames(ps) <- SqlRender::snakeCaseToCamelCase(colnames(ps)) + return(ps) +} + +getKaplanMeier <- function(connection, targetId, comparatorId, outcomeId, databaseId, analysisId) { + sql <- "SELECT time, + target_at_risk, + comparator_at_risk, + target_survival, + target_survival_lb, + target_survival_ub, + comparator_survival, + comparator_survival_lb, + comparator_survival_ub + FROM kaplan_meier_dist + WHERE target_id = @target_id + AND comparator_id = @comparator_id + AND outcome_id = @outcome_id + AND database_id = '@database_id' + AND analysis_id = @analysis_id" + sql <- SqlRender::renderSql(sql, + target_id = targetId, + comparator_id = comparatorId, + outcome_id = outcomeId, + database_id = databaseId, + analysis_id = analysisId)$sql + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + ps <- querySql(connection, sql) + colnames(ps) <- SqlRender::snakeCaseToCamelCase(colnames(ps)) + return(ps) +} + +getAttrition <- function(connection, targetId, comparatorId, outcomeId, analysisId, databaseId) { + sql <- "SELECT exposure_id, + sequence_number, + description, + subjects + FROM attrition + WHERE (target_id IS NULL OR target_id = @target_id) + AND (comparator_id IS NULL OR comparator_id = @comparator_id) + AND (outcome_id IS NULL OR outcome_id = @outcome_id) + AND (exposure_id = @target_id OR exposure_id = @comparator_id) + AND (analysis_id IS NULL OR analysis_id = @analysis_id) + AND database_id = '@database_id'" + sql <- SqlRender::renderSql(sql, + target_id = targetId, + comparator_id = comparatorId, + outcome_id = outcomeId, + analysis_id = analysisId, + database_id = databaseId)$sql + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + attrition <- querySql(connection, sql) + colnames(attrition) <- SqlRender::snakeCaseToCamelCase(colnames(attrition)) + targetAttrition <- attrition[attrition$exposureId == targetId, ] + comparatorAttrition <- attrition[attrition$exposureId == comparatorId, ] + colnames(targetAttrition)[colnames(targetAttrition) == "subjects"] <- "targetPersons" + targetAttrition$exposureId <- NULL + colnames(comparatorAttrition)[colnames(comparatorAttrition) == "subjects"] <- "comparatorPersons" + comparatorAttrition$exposureId <- NULL + attrition <- merge(targetAttrition, comparatorAttrition) + attrition <- attrition[order(attrition$sequenceNumber), ] + return(attrition) +} + +getStudyPeriod <- function(connection, targetId, comparatorId, databaseId) { + sql <- "SELECT min_date, + max_date + FROM comparison_summary + WHERE target_id = @target_id + AND comparator_id = @comparator_id + AND database_id = '@database_id'" + sql <- SqlRender::renderSql(sql, + target_id = targetId, + comparator_id = comparatorId, + database_id = databaseId)$sql + sql <- SqlRender::translateSql(sql, targetDialect = connection@dbms)$sql + studyPeriod <- querySql(connection, sql) + colnames(studyPeriod) <- SqlRender::snakeCaseToCamelCase(colnames(studyPeriod)) + return(studyPeriod) +} diff --git a/LegendBasicViewer/LegendBasicViewer.Rproj b/LegendBasicViewer/LegendBasicViewer.Rproj new file mode 100644 index 00000000..8e3c2ebc --- /dev/null +++ b/LegendBasicViewer/LegendBasicViewer.Rproj @@ -0,0 +1,13 @@ +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX diff --git a/LegendBasicViewer/PlotsAndTables.R b/LegendBasicViewer/PlotsAndTables.R new file mode 100644 index 00000000..d37a3e51 --- /dev/null +++ b/LegendBasicViewer/PlotsAndTables.R @@ -0,0 +1,813 @@ +createTitle <- function(tcoDbs) { + tcoDbs$targetName <- exposures$exposureName[match(tcoDbs$targetId, exposures$exposureId)] + tcoDbs$comparatorName <- exposures$exposureName[match(tcoDbs$comparatorId, exposures$exposureId)] + tcoDbs$outcomeName <- outcomes$outcomeName[match(tcoDbs$outcomeId, outcomes$outcomeId)] + + titles <- paste("A Comparison of", + tcoDbs$targetName, + "to", + tcoDbs$comparatorName, + "for the Risk of", + tcoDbs$outcomeName, + "in the", + tcoDbs$databaseId, + "Database.") + return(titles) +} + +prepareFollowUpDistTable <- function(followUpDist) { + targetRow <- data.frame(Cohort = "Target", + Min = followUpDist$targetMinDays, + P10 = followUpDist$targetP10Days, + P25 = followUpDist$targetP25Days, + Median = followUpDist$targetMedianDays, + P75 = followUpDist$targetP75Days, + P90 = followUpDist$targetP90Days, + Max = followUpDist$targetMaxDays) + comparatorRow <- data.frame(Cohort = "Comparator", + Min = followUpDist$comparatorMinDays, + P10 = followUpDist$comparatorP10Days, + P25 = followUpDist$comparatorP25Days, + Median = followUpDist$comparatorMedianDays, + P75 = followUpDist$comparatorP75Days, + P90 = followUpDist$comparatorP90Days, + Max = followUpDist$comparatorMaxDays) + table <- rbind(targetRow, comparatorRow) + table$Min <- formatC(table$Min, big.mark = ",", format = "d") + table$P10 <- formatC(table$P10, big.mark = ",", format = "d") + table$P25 <- formatC(table$P25, big.mark = ",", format = "d") + table$Median <- formatC(table$Median, big.mark = ",", format = "d") + table$P75 <- formatC(table$P75, big.mark = ",", format = "d") + table$P90 <- formatC(table$P90, big.mark = ",", format = "d") + table$Max <- formatC(table$Max, big.mark = ",", format = "d") + return(table) +} + +prepareMainResultsTable <- function(mainResults, analyses) { + table <- mainResults + table$hr <- sprintf("%.2f (%.2f - %.2f)", mainResults$rr, mainResults$ci95lb, mainResults$ci95ub) + table$p <- sprintf("%.2f", table$p) + table$calHr <- sprintf("%.2f (%.2f - %.2f)", + mainResults$calibratedRr, + mainResults$calibratedCi95Lb, + mainResults$calibratedCi95Ub) + table$calibratedP <- sprintf("%.2f", table$calibratedP) + table <- merge(table, analyses) + table <- table[, c("description", "hr", "p", "calHr", "calibratedP")] + colnames(table) <- c("Analysis", "HR (95% CI)", "P", "Cal. HR (95% CI)", "Cal. p") + return(table) +} + +preparePowerTable <- function(mainResults, analyses) { + table <- merge(mainResults, analyses) + alpha <- 0.05 + power <- 0.8 + z1MinAlpha <- qnorm(1 - alpha/2) + zBeta <- -qnorm(1 - power) + pA <- table$targetSubjects/(table$targetSubjects + table$comparatorSubjects) + pB <- 1 - pA + totalEvents <- abs(table$targetOutcomes) + (table$comparatorOutcomes) + table$mdrr <- exp(sqrt((zBeta + z1MinAlpha)^2/(totalEvents * pA * pB))) + table$targetYears <- table$targetDays/365.25 + table$comparatorYears <- table$comparatorDays/365.25 + table$targetIr <- 1000 * table$targetOutcomes/table$targetYears + table$comparatorIr <- 1000 * table$comparatorOutcomes/table$comparatorYears + table <- table[, c("description", + "targetSubjects", + "comparatorSubjects", + "targetYears", + "comparatorYears", + "targetOutcomes", + "comparatorOutcomes", + "targetIr", + "comparatorIr", + "mdrr")] + table$targetSubjects <- formatC(table$targetSubjects, big.mark = ",", format = "d") + table$comparatorSubjects <- formatC(table$comparatorSubjects, big.mark = ",", format = "d") + table$targetYears <- formatC(table$targetYears, big.mark = ",", format = "d") + table$comparatorYears <- formatC(table$comparatorYears, big.mark = ",", format = "d") + table$targetOutcomes <- formatC(table$targetOutcomes, big.mark = ",", format = "d") + table$comparatorOutcomes <- formatC(table$comparatorOutcomes, big.mark = ",", format = "d") + table$targetIr <- sprintf("%.2f", table$targetIr) + table$comparatorIr <- sprintf("%.2f", table$comparatorIr) + table$mdrr <- sprintf("%.2f", table$mdrr) + table$targetSubjects <- gsub("^-", "<", table$targetSubjects) + table$comparatorSubjects <- gsub("^-", "<", table$comparatorSubjects) + table$targetOutcomes <- gsub("^-", "<", table$targetOutcomes) + table$comparatorOutcomes <- gsub("^-", "<", table$comparatorOutcomes) + table$targetIr <- gsub("^-", "<", table$targetIr) + table$comparatorIr <- gsub("^-", "<", table$comparatorIr) + idx <- (table$targetOutcomes < 0 | table$comparatorOutcomes < 0) + table$mdrr[idx] <- paste0(">", table$mdrr[idx]) + return(table) +} + + +prepareSubgroupTable <- function(subgroupResults, output = "latex") { + rnd <- function(x) { + ifelse(x > 10, sprintf("%.1f", x), sprintf("%.2f", x)) + } + + subgroupResults$hrr <- paste0(rnd(subgroupResults$rrr), + " (", + rnd(subgroupResults$ci95Lb), + " - ", + rnd(subgroupResults$ci95Ub), + ")") + + subgroupResults$hrr[is.na(subgroupResults$rrr)] <- "" + subgroupResults$p <- sprintf("%.2f", subgroupResults$p) + subgroupResults$p[subgroupResults$p == "NA"] <- "" + subgroupResults$calibratedP <- sprintf("%.2f", subgroupResults$calibratedP) + subgroupResults$calibratedP[subgroupResults$calibratedP == "NA"] <- "" + + if (any(grepl("on-treatment", subgroupResults$analysisDescription)) && + any(grepl("intent-to-treat", subgroupResults$analysisDescription))) { + idx <- grepl("on-treatment", subgroupResults$analysisDescription) + onTreatment <- subgroupResults[idx, c("interactionCovariateName", + "targetSubjects", + "comparatorSubjects", + "hrr", + "p", + "calibratedP")] + itt <- subgroupResults[!idx, c("interactionCovariateName", "hrr", "p", "calibratedP")] + colnames(onTreatment)[4:6] <- paste("onTreatment", colnames(onTreatment)[4:6], sep = "_") + colnames(itt)[2:4] <- paste("itt", colnames(itt)[2:4], sep = "_") + table <- merge(onTreatment, itt) + } else { + table <- subgroupResults[, c("interactionCovariateName", + "targetSubjects", + "comparatorSubjects", + "hrr", + "p", + "calibratedP")] + } + table$interactionCovariateName <- gsub("Subgroup: ", "", table$interactionCovariateName) + if (output == "latex") { + table$interactionCovariateName <- gsub(">=", "$\\\\ge$ ", table$interactionCovariateName) + } + table$targetSubjects <- formatC(table$targetSubjects, big.mark = ",", format = "d") + table$targetSubjects <- gsub("^-", "<", table$targetSubjects) + table$comparatorSubjects <- formatC(table$comparatorSubjects, big.mark = ",", format = "d") + table$comparatorSubjects <- gsub("^-", "<", table$comparatorSubjects) + table$comparatorSubjects <- gsub("^<", "$<$", table$comparatorSubjects) + return(table) +} + +prepareTable1 <- function(balance, + beforeLabel = "Before stratification", + afterLabel = "After stratification", + targetLabel = "Target", + comparatorLabel = "Comparator", + percentDigits = 1, + stdDiffDigits = 2, + output = "latex") { + if (output == "latex") { + space <- " " + } else { + space <- " " + } + pathToCsv <- "Table1Specs.csv" + specifications <- read.csv(pathToCsv, stringsAsFactors = FALSE) + + fixCase <- function(label) { + idx <- (toupper(label) == label) + if (any(idx)) { + label[idx] <- paste0(substr(label[idx], 1, 1), + tolower(substr(label[idx], 2, nchar(label[idx])))) + } + return(label) + } + + formatPercent <- function(x) { + result <- format(round(100 * x, percentDigits), digits = percentDigits + 1, justify = "right") + result <- gsub("^-", "<", result) + result <- gsub("NA", "", result) + result <- gsub(" ", space, result) + return(result) + } + + formatStdDiff <- function(x) { + result <- format(round(x, stdDiffDigits), digits = stdDiffDigits + 1, justify = "right") + result <- gsub("NA", "", result) + result <- gsub(" ", space, result) + return(result) + } + + resultsTable <- data.frame() + for (i in 1:nrow(specifications)) { + if (specifications$analysisId[i] == "") { + resultsTable <- rbind(resultsTable, + data.frame(Characteristic = specifications$label[i], value = "")) + } else { + idx <- balance$analysisId == specifications$analysisId[i] + if (any(idx)) { + if (specifications$covariateIds[i] != "") { + covariateIds <- as.numeric(strsplit(specifications$covariateIds[i], ";")[[1]]) + idx <- balance$covariateId %in% covariateIds + } else { + covariateIds <- NULL + } + if (any(idx)) { + balanceSubset <- balance[idx, ] + if (is.null(covariateIds)) { + balanceSubset <- balanceSubset[order(balanceSubset$covariateId), ] + } else { + balanceSubset <- merge(balanceSubset, data.frame(covariateId = covariateIds, + rn = 1:length(covariateIds))) + balanceSubset <- balanceSubset[order(balanceSubset$rn, balanceSubset$covariateId), ] + } + balanceSubset$covariateName <- fixCase(gsub("^.*: ", "", balanceSubset$covariateName)) + if (specifications$covariateIds[i] == "" || length(covariateIds) > 1) { + resultsTable <- rbind(resultsTable, data.frame(Characteristic = specifications$label[i], + beforeMatchingMeanTreated = NA, + beforeMatchingMeanComparator = NA, + beforeMatchingStdDiff = NA, + afterMatchingMeanTreated = NA, + afterMatchingMeanComparator = NA, + afterMatchingStdDiff = NA, + stringsAsFactors = FALSE)) + resultsTable <- rbind(resultsTable, data.frame(Characteristic = paste0(space, + space, + space, + space, + balanceSubset$covariateName), + beforeMatchingMeanTreated = balanceSubset$beforeMatchingMeanTreated, + beforeMatchingMeanComparator = balanceSubset$beforeMatchingMeanComparator, + beforeMatchingStdDiff = balanceSubset$beforeMatchingStdDiff, + afterMatchingMeanTreated = balanceSubset$afterMatchingMeanTreated, + afterMatchingMeanComparator = balanceSubset$afterMatchingMeanComparator, + afterMatchingStdDiff = balanceSubset$afterMatchingStdDiff, + stringsAsFactors = FALSE)) + } else { + resultsTable <- rbind(resultsTable, data.frame(Characteristic = specifications$label[i], + beforeMatchingMeanTreated = balanceSubset$beforeMatchingMeanTreated, + beforeMatchingMeanComparator = balanceSubset$beforeMatchingMeanComparator, + beforeMatchingStdDiff = balanceSubset$beforeMatchingStdDiff, + afterMatchingMeanTreated = balanceSubset$afterMatchingMeanTreated, + afterMatchingMeanComparator = balanceSubset$afterMatchingMeanComparator, + afterMatchingStdDiff = balanceSubset$afterMatchingStdDiff, + stringsAsFactors = FALSE)) + } + } + } + } + } + resultsTable$beforeMatchingMeanTreated <- formatPercent(resultsTable$beforeMatchingMeanTreated) + resultsTable$beforeMatchingMeanComparator <- formatPercent(resultsTable$beforeMatchingMeanComparator) + resultsTable$beforeMatchingStdDiff <- formatStdDiff(resultsTable$beforeMatchingStdDiff) + resultsTable$afterMatchingMeanTreated <- formatPercent(resultsTable$afterMatchingMeanTreated) + resultsTable$afterMatchingMeanComparator <- formatPercent(resultsTable$afterMatchingMeanComparator) + resultsTable$afterMatchingStdDiff <- formatStdDiff(resultsTable$afterMatchingStdDiff) + + headerRow <- as.data.frame(t(rep("", ncol(resultsTable)))) + colnames(headerRow) <- colnames(resultsTable) + headerRow$beforeMatchingMeanTreated <- targetLabel + headerRow$beforeMatchingMeanComparator <- comparatorLabel + headerRow$afterMatchingMeanTreated <- targetLabel + headerRow$afterMatchingMeanComparator <- comparatorLabel + + subHeaderRow <- as.data.frame(t(rep("", ncol(resultsTable)))) + colnames(subHeaderRow) <- colnames(resultsTable) + subHeaderRow$Characteristic <- "Characteristic" + subHeaderRow$beforeMatchingMeanTreated <- "%" + subHeaderRow$beforeMatchingMeanComparator <- "%" + subHeaderRow$beforeMatchingStdDiff <- "Std. diff" + subHeaderRow$afterMatchingMeanTreated <- "%" + subHeaderRow$afterMatchingMeanComparator <- "%" + subHeaderRow$afterMatchingStdDiff <- "Std. diff" + + resultsTable <- rbind(headerRow, subHeaderRow, resultsTable) + + colnames(resultsTable) <- rep("", ncol(resultsTable)) + colnames(resultsTable)[2] <- beforeLabel + colnames(resultsTable)[5] <- afterLabel + return(resultsTable) +} + +plotPs <- function(ps, targetName, comparatorName) { + ps <- rbind(data.frame(x = ps$preferenceScore, y = ps$targetDensity, group = targetName), + data.frame(x = ps$preferenceScore, y = ps$comparatorDensity, group = comparatorName)) + ps$group <- factor(ps$group, levels = c(as.character(targetName), as.character(comparatorName))) + theme <- ggplot2::element_text(colour = "#000000", size = 12) + plot <- ggplot2::ggplot(ps, + ggplot2::aes(x = x, y = y, color = group, group = group, fill = group)) + + ggplot2::geom_density(stat = "identity") + + ggplot2::scale_fill_manual(values = c(rgb(0.8, 0, 0, alpha = 0.5), + rgb(0, 0, 0.8, alpha = 0.5))) + + ggplot2::scale_color_manual(values = c(rgb(0.8, 0, 0, alpha = 0.5), + rgb(0, 0, 0.8, alpha = 0.5))) + + ggplot2::scale_x_continuous("Preference score", limits = c(0, 1)) + + ggplot2::scale_y_continuous("Density") + + ggplot2::theme(legend.title = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + legend.position = "top", + legend.text = theme, + axis.text = theme, + axis.title = theme) + return(plot) +} + +plotAllPs <- function(ps) { + ps <- rbind(data.frame(targetName = ps$targetName, + comparatorName = ps$comparatorName, + x = ps$preferenceScore, + y = ps$targetDensity, + group = "Target"), + data.frame(targetName = ps$targetName, + comparatorName = ps$comparatorName, + x = ps$preferenceScore, + y = ps$comparatorDensity, + group = "Comparator")) + ps$group <- factor(ps$group, levels = c("Target", "Comparator")) + plot <- ggplot2::ggplot(ps, ggplot2::aes(x = x, y = y, color = group, group = group, fill = group)) + + ggplot2::geom_density(stat = "identity") + + ggplot2::scale_fill_manual(values = c(rgb(0.8, 0, 0, alpha = 0.5), rgb(0, 0, 0.8, alpha = 0.5))) + + ggplot2::scale_color_manual(values = c(rgb(0.8, 0, 0, alpha = 0.5), rgb(0, 0, 0.8, alpha = 0.5))) + + ggplot2::scale_x_continuous("Preference score", limits = c(0, 1)) + + ggplot2::scale_y_continuous("Density") + + ggplot2::facet_grid(targetName ~ comparatorName) + + ggplot2::theme(legend.title = ggplot2::element_blank(), + axis.title.x = ggplot2::element_blank(), + axis.text.x = ggplot2::element_blank(), + axis.ticks.x = ggplot2::element_blank(), + axis.title.y = ggplot2::element_blank(), + axis.text.y = ggplot2::element_blank(), + axis.ticks.y = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + strip.text.x = ggplot2::element_text(size = 12, angle = 90, vjust = 0), + strip.text.y = ggplot2::element_text(size = 12, angle = 0, hjust = 0), + panel.spacing = ggplot2::unit(0.1, "lines"), + legend.position = "none") + return(plot) +} + + +plotCovariateBalanceScatterPlot <- function(balance, beforeLabel = "Before stratification", afterLabel = "After stratification") { + limits <- c(min(c(balance$absBeforeMatchingStdDiff, balance$absAfterMatchingStdDiff), + na.rm = TRUE), + max(c(balance$absBeforeMatchingStdDiff, balance$absAfterMatchingStdDiff), + na.rm = TRUE)) + theme <- ggplot2::element_text(colour = "#000000", size = 12) + plot <- ggplot2::ggplot(balance, ggplot2::aes(x = absBeforeMatchingStdDiff, y = absAfterMatchingStdDiff)) + + ggplot2::geom_point(color = rgb(0, 0, 0.8, alpha = 0.3), shape = 16, size = 2) + + ggplot2::geom_abline(slope = 1, intercept = 0, linetype = "dashed") + + ggplot2::geom_hline(yintercept = 0) + + ggplot2::geom_vline(xintercept = 0) + + ggplot2::scale_x_continuous(beforeLabel, limits = limits) + + ggplot2::scale_y_continuous(afterLabel, limits = limits) + + ggplot2::theme(text = theme) + + return(plot) +} + +plotKaplanMeier <- function(kaplanMeier, targetName, comparatorName) { + data <- rbind(data.frame(time = kaplanMeier$time, + s = kaplanMeier$targetSurvival, + lower = kaplanMeier$targetSurvivalLb, + upper = kaplanMeier$targetSurvivalUb, + strata = paste0(" ", targetName, " ")), + data.frame(time = kaplanMeier$time, + s = kaplanMeier$comparatorSurvival, + lower = kaplanMeier$comparatorSurvivalLb, + upper = kaplanMeier$comparatorSurvivalUb, + strata = paste0(" ", comparatorName))) + + xlims <- c(-max(data$time)/40, max(data$time)) + ylims <- c(min(data$lower), 1) + xLabel <- "Time in days" + yLabel <- "Survival probability" + xBreaks <- kaplanMeier$time[!is.na(kaplanMeier$targetAtRisk)] + plot <- ggplot2::ggplot(data, ggplot2::aes(x = time, + y = s, + color = strata, + fill = strata, + ymin = lower, + ymax = upper)) + + ggplot2::geom_ribbon(color = rgb(0, 0, 0, alpha = 0)) + + ggplot2::geom_step(size = 1) + + ggplot2::scale_color_manual(values = c(rgb(0.8, 0, 0, alpha = 0.8), + rgb(0, 0, 0.8, alpha = 0.8))) + + ggplot2::scale_fill_manual(values = c(rgb(0.8, 0, 0, alpha = 0.3), + rgb(0, 0, 0.8, alpha = 0.3))) + + ggplot2::scale_x_continuous(xLabel, limits = xlims, breaks = xBreaks) + + ggplot2::scale_y_continuous(yLabel, limits = ylims) + + ggplot2::theme(legend.title = ggplot2::element_blank(), + legend.position = "top", + legend.key.size = ggplot2::unit(1, "lines"), + plot.title = ggplot2::element_text(hjust = 0.5)) + + ggplot2::theme(axis.title.y = ggplot2::element_text(vjust = -10)) + + targetAtRisk <- kaplanMeier$targetAtRisk[!is.na(kaplanMeier$targetAtRisk)] + comparatorAtRisk <- kaplanMeier$comparatorAtRisk[!is.na(kaplanMeier$comparatorAtRisk)] + labels <- data.frame(x = c(0, xBreaks, xBreaks), + y = as.factor(c("Number at risk", + rep(targetName, length(xBreaks)), + rep(comparatorName, length(xBreaks)))), + label = c("", + formatC(targetAtRisk, big.mark = ",", mode = "integer"), + formatC(comparatorAtRisk, big.mark = ",", mode = "integer"))) + labels$y <- factor(labels$y, levels = c(comparatorName, targetName, "Number at risk")) + dataTable <- ggplot2::ggplot(labels, ggplot2::aes(x = x, y = y, label = label)) + ggplot2::geom_text(size = 3.5, vjust = 0.5) + ggplot2::scale_x_continuous(xLabel, + limits = xlims, + breaks = xBreaks) + ggplot2::theme(panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + legend.position = "none", + panel.border = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + axis.text.x = ggplot2::element_text(color = "white"), + axis.title.x = ggplot2::element_text(color = "white"), + axis.title.y = ggplot2::element_blank(), + axis.ticks = ggplot2::element_line(color = "white")) + plots <- list(plot, dataTable) + grobs <- widths <- list() + for (i in 1:length(plots)) { + grobs[[i]] <- ggplot2::ggplotGrob(plots[[i]]) + widths[[i]] <- grobs[[i]]$widths[2:5] + } + maxwidth <- do.call(grid::unit.pmax, widths) + for (i in 1:length(grobs)) { + grobs[[i]]$widths[2:5] <- as.list(maxwidth) + } + plot <- gridExtra::grid.arrange(grobs[[1]], grobs[[2]], heights = c(400, 100)) + return(plot) +} + +judgeCoverage <- function(values) { + ifelse(any(values < 0.9), "poor", "acceptable") +} + +getCoverage <- function(controlResults) { + d <- rbind(data.frame(yGroup = "Uncalibrated", + logRr = controlResults$logRr, + seLogRr = controlResults$seLogRr, + ci95lb = controlResults$ci95lb, + ci95ub = controlResults$ci95ub, + trueRr = controlResults$effectSize), + data.frame(yGroup = "Calibrated", + logRr = controlResults$calibratedLogRr, + seLogRr = controlResults$calibratedSeLogRr, + ci95lb = controlResults$calibratedCi95Lb, + ci95ub = controlResults$calibratedCi95Ub, + trueRr = controlResults$effectSize)) + d <- d[!is.na(d$logRr), ] + d <- d[!is.na(d$ci95lb), ] + d <- d[!is.na(d$ci95ub), ] + if (nrow(d) == 0) { + return(NULL) + } + + d$Group <- as.factor(d$trueRr) + d$Significant <- d$ci95lb > d$trueRr | d$ci95ub < d$trueRr + + temp2 <- aggregate(Significant ~ Group + yGroup, data = d, mean) + temp2$coverage <- (1 - temp2$Significant) + + data.frame(true = temp2$Group, group = temp2$yGroup, coverage = temp2$coverage) +} + +plotScatter <- function(controlResults) { + size <- 2 + labelY <- 0.7 + d <- rbind(data.frame(yGroup = "Uncalibrated", + logRr = controlResults$logRr, + seLogRr = controlResults$seLogRr, + ci95lb = controlResults$ci95lb, + ci95ub = controlResults$ci95ub, + trueRr = controlResults$effectSize), + data.frame(yGroup = "Calibrated", + logRr = controlResults$calibratedLogRr, + seLogRr = controlResults$calibratedSeLogRr, + ci95lb = controlResults$calibratedCi95Lb, + ci95ub = controlResults$calibratedCi95Ub, + trueRr = controlResults$effectSize)) + d <- d[!is.na(d$logRr), ] + d <- d[!is.na(d$ci95lb), ] + d <- d[!is.na(d$ci95ub), ] + if (nrow(d) == 0) { + return(NULL) + } + d$Group <- as.factor(d$trueRr) + d$Significant <- d$ci95lb > d$trueRr | d$ci95ub < d$trueRr + temp1 <- aggregate(Significant ~ Group + yGroup, data = d, length) + temp2 <- aggregate(Significant ~ Group + yGroup, data = d, mean) + temp1$nLabel <- paste0(formatC(temp1$Significant, big.mark = ","), " estimates") + temp1$Significant <- NULL + + temp2$meanLabel <- paste0(formatC(100 * (1 - temp2$Significant), digits = 1, format = "f"), + "% of CIs include ", + temp2$Group) + temp2$Significant <- NULL + dd <- merge(temp1, temp2) + dd$tes <- as.numeric(as.character(dd$Group)) + + breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8, 10) + theme <- ggplot2::element_text(colour = "#000000", size = 12) + themeRA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 1) + themeLA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 0) + + d$Group <- paste("True hazard ratio =", d$Group) + dd$Group <- paste("True hazard ratio =", dd$Group) + alpha <- 1 - min(0.95 * (nrow(d)/nrow(dd)/50000)^0.1, 0.95) + plot <- ggplot2::ggplot(d, ggplot2::aes(x = logRr, y = seLogRr), environment = environment()) + + ggplot2::geom_vline(xintercept = log(breaks), colour = "#AAAAAA", lty = 1, size = 0.5) + + ggplot2::geom_abline(ggplot2::aes(intercept = (-log(tes))/qnorm(0.025), slope = 1/qnorm(0.025)), + colour = rgb(0.8, 0, 0), + linetype = "dashed", + size = 1, + alpha = 0.5, + data = dd) + + ggplot2::geom_abline(ggplot2::aes(intercept = (-log(tes))/qnorm(0.975), slope = 1/qnorm(0.975)), + colour = rgb(0.8, 0, 0), + linetype = "dashed", + size = 1, + alpha = 0.5, + data = dd) + + ggplot2::geom_point(size = size, + color = rgb(0, 0, 0, alpha = 0.05), + alpha = alpha, + shape = 16) + + ggplot2::geom_hline(yintercept = 0) + + ggplot2::geom_label(x = log(0.15), + y = 0.9, + alpha = 1, + hjust = "left", + ggplot2::aes(label = nLabel), + size = 5, + data = dd) + + ggplot2::geom_label(x = log(0.15), + y = labelY, + alpha = 1, + hjust = "left", + ggplot2::aes(label = meanLabel), + size = 5, + data = dd) + + ggplot2::scale_x_continuous("Hazard ratio", + limits = log(c(0.1, 10)), + breaks = log(breaks), + labels = breaks) + + ggplot2::scale_y_continuous("Standard Error", limits = c(0, 1)) + + ggplot2::facet_grid(yGroup ~ Group) + + ggplot2::theme(panel.grid.minor = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + axis.ticks = ggplot2::element_blank(), + axis.text.y = themeRA, + axis.text.x = theme, + axis.title = theme, + legend.key = ggplot2::element_blank(), + strip.text.x = theme, + strip.text.y = theme, + strip.background = ggplot2::element_blank(), + legend.position = "none") + + return(plot) +} + +plotLargeScatter <- function(d, xLabel) { + d$Significant <- d$ci95lb > 1 | d$ci95ub < 1 + + oneRow <- data.frame(nLabel = paste0(formatC(nrow(d), big.mark = ","), " estimates"), + meanLabel = paste0(formatC(100 * + mean(!d$Significant, na.rm = TRUE), digits = 1, format = "f"), "% of CIs includes 1")) + + breaks <- c(0.1, 0.25, 0.5, 1, 2, 4, 6, 8, 10) + theme <- ggplot2::element_text(colour = "#000000", size = 12) + themeRA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 1) + themeLA <- ggplot2::element_text(colour = "#000000", size = 12, hjust = 0) + + alpha <- 1 - min(0.95 * (nrow(d)/50000)^0.1, 0.95) + plot <- ggplot2::ggplot(d, ggplot2::aes(x = logRr, y = seLogRr)) + + ggplot2::geom_vline(xintercept = log(breaks), colour = "#AAAAAA", lty = 1, size = 0.5) + + ggplot2::geom_abline(ggplot2::aes(intercept = 0, slope = 1/qnorm(0.025)), + colour = rgb(0.8, 0, 0), + linetype = "dashed", + size = 1, + alpha = 0.5) + + ggplot2::geom_abline(ggplot2::aes(intercept = 0, slope = 1/qnorm(0.975)), + colour = rgb(0.8, 0, 0), + linetype = "dashed", + size = 1, + alpha = 0.5) + + ggplot2::geom_point(size = 2, color = rgb(0, 0, 0, alpha = 0.05), alpha = alpha, shape = 16) + + ggplot2::geom_hline(yintercept = 0) + + ggplot2::geom_label(x = log(0.11), + y = 1, + alpha = 1, + hjust = "left", + ggplot2::aes(label = nLabel), + size = 5, + data = oneRow) + + ggplot2::geom_label(x = log(0.11), + y = 0.935, + alpha = 1, + hjust = "left", + ggplot2::aes(label = meanLabel), + size = 5, + data = oneRow) + + ggplot2::scale_x_continuous(xLabel, limits = log(c(0.1, + 10)), breaks = log(breaks), labels = breaks) + + ggplot2::scale_y_continuous("Standard Error", limits = c(0, 1)) + + ggplot2::theme(panel.grid.minor = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + axis.ticks = ggplot2::element_blank(), + axis.text.y = themeRA, + axis.text.x = theme, + axis.title = theme, + legend.key = ggplot2::element_blank(), + strip.text.x = theme, + strip.background = ggplot2::element_blank(), + legend.position = "none") + return(plot) +} + + + +drawAttritionDiagram <- 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 = 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 = 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("\"", text, "\"", + 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) +} + +judgeHazardRatio <- function(hrLower, hrUpper) { + nonZeroHazardRatio(hrLower, hrUpper, c("lower", "higher", "similar")) +} + +nonZeroHazardRatio <- function(hrLower, hrUpper, terms) { + if (hrUpper < 1) { + return(terms[1]) + } else if (hrLower > 1) { + return(terms[2]) + } else { + return(terms[3]) + } +} + +judgeEffectiveness <- function(hrLower, hrUpper) { + nonZeroHazardRatio(hrLower, hrUpper, c("less", "more", "as")) +} + +prettyHr <- function(x) { + result <- sprintf("%.2f", x) + result[is.na(x) | x > 100] <- "NA" + return(result) +} + +goodPropensityScore <- function(value) { + return(value > 1) +} + +goodSystematicBias <- function(value) { + return(value > 1) +} + +judgePropensityScore <- function(ps, bias) { + paste0(" ", + ifelse(goodPropensityScore(ps), "substantial", "inadequate"), + " control of measured confounding by propensity score adjustment, and ", + ifelse(goodSystematicBias(bias), "minimal", "non-negligible"), + " residual systematic bias through negative and positive control experiments", + ifelse(goodPropensityScore(ps) && goodSystematicBias(bias), + ", lending credibility to our effect estimates", + "")) +} + +capitalize <- function(x) { + substr(x, 1, 1) <- toupper(substr(x, 1, 1)) + x +} diff --git a/LegendBasicViewer/Table1Specs.csv b/LegendBasicViewer/Table1Specs.csv new file mode 100644 index 00000000..6389f2be --- /dev/null +++ b/LegendBasicViewer/Table1Specs.csv @@ -0,0 +1,9 @@ +label,analysisId,covariateIds +Age group,3, +Gender: female,1,8532001 +Race,4, +Ethnicity,5, +Medical history: General,210,4006969210;438409210;4212540210;255573210;201606210;4182210210;440383210;201820210;318800210;192671210;439727210;432867210;316866210;4104000210;433736210;80180210;255848210;140168210;4030518210;80809210;435783210;4279309210;81893210;81902210;197494210;4134440210 +Medical history: Cardiovascular disease,210,313217210;381591210;317576210;321588210;316139210;4185932210;321052210;440417210;444247210 +Medical history: Neoplasms,210,4044013210;432571210;40481902210;443392210;4112853210;4180790210;443388210;197508210;200962210 +Medication use,410,21601782410;21602796410;21604686410;21604389410;21603932410;21601387410;21602028410;21600960410;21601664410;21601744410;21601461410;21600046410;21603248410;21600712410;21603890410;21601853410;21604254410;21604489410;21604752410 diff --git a/LegendBasicViewer/global.R b/LegendBasicViewer/global.R new file mode 100644 index 00000000..69a0c653 --- /dev/null +++ b/LegendBasicViewer/global.R @@ -0,0 +1,46 @@ +library(DatabaseConnector) +source("DataPulls.R") +source("PlotsAndTables.R") + +# connectionDetails <- createConnectionDetails(dbms = 'postgresql', server = 'localhost/ohdsi', user +# = 'postgres', password = Sys.getenv('pwPostgres'), schema = 'legend') + +# connectionDetails <- createConnectionDetails(dbms = "postgresql", +# server = paste(Sys.getenv("legendServer"), +# Sys.getenv("legendDatabase"), +# sep = "/"), +# port = Sys.getenv("legendPort"), +# user = Sys.getenv("legendUser"), +# password = Sys.getenv("legendPw"), +# schema = Sys.getenv("legendSchema")) + +connectionDetails <- createConnectionDetails(dbms = "postgresql", + server = paste(Sys.getenv("shinydbServer"), + Sys.getenv("shinydbDatabase"), + sep = "/"), + port = Sys.getenv("shinydbPort"), + user = Sys.getenv("shinydbUser"), + password = Sys.getenv("shinydbPw"), + schema = Sys.getenv("shinydbSchema")) + +connection <- connect(connectionDetails) + +indications <- getIndications(connection) +exposures <- getExposures(connection) +exposures$exposureGroup[exposures$exposureGroup == "Drug" | exposures$exposureGroup == "Procedure"] <- "Drug or procedure" +exposureGroups <- unique(exposures[, c("indicationId", "exposureGroup")]) +outcomes <- getOutcomes(connection) +databases <- getDatabases(connection) +analyses <- getAnalyses(connection) +subgroups <- getSubgroups(connection) + + +# sql <- "SELECT target_id,\n comparator_id,\n outcome_id,\n cm_interaction_result.analysis_id,\n cohort_method_analysis.description AS analysis_description,\n cm_interaction_result.database_id,\n interaction_covariate_id,\n covariate_name AS interaction_covariate_name,\n rrr,\n ci_95_lb,\n ci_95_ub,\n p,\n calibrated_p,\n i_2,\n log_rrr,\n se_log_rrr,\n target_subjects,\n comparator_subjects,\n target_days,\n comparator_days,\n target_outcomes,\n comparator_outcomes\n FROM cm_interaction_result\n INNER JOIN covariate\n ON cm_interaction_result.interaction_covariate_id = covariate.covariate_id\n AND cm_interaction_result.database_id = covariate.database_id\n INNER JOIN cohort_method_analysis\n ON cm_interaction_result.analysis_id = cohort_method_analysis.analysis_id WHERE target_id IN (18) AND comparator_id IN (17) AND outcome_id IN (24) AND cm_interaction_result.database_id IN ('JMDC')" +# x <- querySql(connection, sql) +# nrow(x) + + +# head(x) +# +# +# sql <- "SELECT DISTINCT(outcome_id) FROM covariate_balance" diff --git a/LegendBasicViewer/server.R b/LegendBasicViewer/server.R new file mode 100644 index 00000000..995b210c --- /dev/null +++ b/LegendBasicViewer/server.R @@ -0,0 +1,766 @@ +library(shiny) +library(DT) + +mainColumns <- c("description", + "databaseId", + "rr", + "ci95lb", + "ci95ub", + "p", + "calibratedRr", + "calibratedCi95Lb", + "calibratedCi95Ub", + "calibratedP") + +mainColumnNames <- c("Analysis", + "Data source", + "HR", + "LB", + "UB", + "P", + "Cal.HR", + "Cal.LB", + "Cal.UB", + "Cal.P") + +shinyServer(function(input, output, session) { + # Specific research questions tab --------------------------------------------------------------------------- + observe({ + indicationId <- input$indication + updateSelectInput(session = session, + inputId = "exposureGroup", + choices = unique(exposureGroups$exposureGroup[exposureGroups$indicationId == indicationId])) + }) + + observe({ + indicationId <- input$indication + exposureGroup <- input$exposureGroup + filteredExposures <- exposures[exposures$indicationId == indicationId, ] + filteredOutcomes <- outcomes[outcomes$indicationId == indicationId, ] + filteredExposures <- filteredExposures[filteredExposures$exposureGroup == exposureGroup, ] + updateSelectInput(session = session, + inputId = "target", + choices = unique(filteredExposures$exposureName)) + updateSelectInput(session = session, + inputId = "comparator", + choices = unique(filteredExposures$exposureName)) + }) + + resultSubset <- reactive({ + targetId <- unique(exposures$exposureId[exposures$exposureName == input$target]) + comparatorId <- unique(exposures$exposureId[exposures$exposureName == input$comparator]) + outcomeId <- unique(outcomes$outcomeId[outcomes$outcomeName == input$outcome]) + analysisIds <- analyses$analysisId[analyses$description %in% input$analysis] + databaseIds <- input$database + if (length(analysisIds) == 0) { + analysisIds <- -1 + } + if (length(databaseIds) == 0) { + databaseIds <- "none" + } + results <- getMainResults(connection = connection, + targetIds = targetId, + comparatorIds = comparatorId, + outcomeIds = outcomeId, + databaseIds = databaseIds, + analysisIds = analysisIds) + return(results) + }) + + selectedRow <- reactive({ + idx <- input$mainTable_rows_selected + if (is.null(idx)) { + return(NULL) + } else { + row <- resultSubset()[idx, ] + row$psStrategy <- gsub("^PS ", "", gsub(", .*$", "", analyses$description[analyses$analysisId == row$analysisId])) + return(row) + } + }) + + output$rowIsSelected <- reactive({ + return(!is.null(selectedRow())) + }) + outputOptions(output, "rowIsSelected", suspendWhenHidden = FALSE) + + balance <- reactive({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + targetId <- unique(exposures$exposureId[exposures$exposureName == input$target]) + comparatorId <- unique(exposures$exposureId[exposures$exposureName == input$comparator]) + analysisId <- row$analysisId + if (analysisId %in% c(1, 3)) { + # Only computed balance for ITT windows + analysisId <- analysisId + 1 + } + writeLines("Fetching covariate balance") + balance <- getCovariateBalance(connection = connection, + targetId = targetId , + comparatorId = comparatorId, + databaseId = row$databaseId, + analysisId = analysisId) + print(nrow(balance)) + return(balance) + } + }) + + output$mainTable <- renderDataTable({ + table <- resultSubset() + if (is.null(table) || nrow(table) == 0) { + return(NULL) + } + table <- merge(table, analyses) + table <- table[, mainColumns] + table$rr <- prettyHr(table$rr) + table$ci95lb <- prettyHr(table$ci95lb) + table$ci95ub <- prettyHr(table$ci95ub) + table$p <- prettyHr(table$p) + table$calibratedRr <- prettyHr(table$calibratedRr) + table$calibratedCi95Lb <- prettyHr(table$calibratedCi95Lb) + table$calibratedCi95Ub <- prettyHr(table$calibratedCi95Ub) + table$calibratedP <- prettyHr(table$calibratedP) + colnames(table) <- mainColumnNames + options = list(pageLength = 15, + searching = FALSE, + lengthChange = TRUE, + ordering = TRUE, + paging = TRUE) + selection = list(mode = "single", target = "row") + table <- datatable(table, + options = options, + selection = selection, + rownames = FALSE, + escape = FALSE, + class = "stripe nowrap compact") + return(table) + }) + + output$powerTableCaption <- renderUI({ + row <- selectedRow() + if (!is.null(row)) { + text <- "Table 1a. Number of subjects, follow-up time (in years), number of outcome + events, and event incidence rate (IR) per 1,000 patient years (PY) in the target (%s) and + comparator (%s) group after %s, as well as the minimum detectable relative risk (MDRR). + Note that the IR does not account for any stratification." + return(HTML(sprintf(text, input$target, input$comparator, row$psStrategy))) + } else { + return(NULL) + } + }) + + output$powerTable <- renderTable({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + table <- preparePowerTable(row, analyses) + table$description <- NULL + colnames(table) <- c("Target subjects", + "Comparator subjects", + "Target years", + "Comparator years", + "Target events", + "Comparator events", + "Target IR (per 1,000 PY)", + "Comparator IR (per 1,000 PY)", + "MDRR") + return(table) + } + }) + + output$timeAtRiskTableCaption <- renderUI({ + row <- selectedRow() + if (!is.null(row)) { + text <- "Table 1b. Time (days) at risk distribution expressed as + minimum (min), 25th percentile (P25), median, 75th percentile (P75), and maximum (max) in the target + (%s) and comparator (%s) cohort after %s." + return(HTML(sprintf(text, input$target, input$comparator, row$psStrategy))) + } else { + return(NULL) + } + }) + + output$timeAtRiskTable <- renderTable({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + targetId <- unique(exposures$exposureId[exposures$exposureName == input$target]) + comparatorId <- unique(exposures$exposureId[exposures$exposureName == input$comparator]) + outcomeId <- unique(outcomes$outcomeId[outcomes$outcomeName == input$outcome]) + followUpDist <- getCmFollowUpDist(connection = connection, + targetId = targetId, + comparatorId = comparatorId, + outcomeId = outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId) + table <- prepareFollowUpDistTable(followUpDist) + return(table) + } + }) + + output$attritionPlot <- renderPlot({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + targetId <- unique(exposures$exposureId[exposures$exposureName == input$target]) + comparatorId <- unique(exposures$exposureId[exposures$exposureName == input$comparator]) + outcomeId <- unique(outcomes$outcomeId[outcomes$outcomeName == input$outcome]) + attrition <- getAttrition(connection = connection, + targetId = targetId, + comparatorId = comparatorId, + outcomeId = outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId) + plot <- drawAttritionDiagram(attrition) + return(plot) + } + }) + + output$attritionPlotCaption <- renderUI({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + text <- "Figure 1. Attrition diagram, showing the Number of subjectsin the target (%s) and + comparator (%s) group after various stages in the analysis." + return(HTML(sprintf(text, input$target, input$comparator))) + } + }) + + output$table1Caption <- renderUI({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + text <- "Table 2. Select characteristics before and after %s, showing the (weighted) + percentage of subjects with the characteristics in the target (%s) and comparator (%s) group, as + well as the standardized difference of the means." + return(HTML(sprintf(text, row$psStrategy, input$target, input$comparator))) + } + }) + + output$table1Table <- renderDataTable({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + targetId <- unique(exposures$exposureId[exposures$exposureName == input$target]) + comparatorId <- unique(exposures$exposureId[exposures$exposureName == input$comparator]) + outcomeId <- unique(outcomes$outcomeId[outcomes$outcomeName == input$outcome]) + chars <- getCovariateBalance(connection = connection, + targetId = targetId, + comparatorId = comparatorId, + outcomeId = outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId) + table1 <- prepareTable1(balance = chars, + beforeLabel = paste("Before" , row$psStrategy), + afterLabel = paste("Before" , row$psStrategy)) + + container <- htmltools::withTags(table( + class = 'display', + thead( + tr( + th(rowspan = 3, "Characteristic"), + th(colspan = 3, class = "dt-center", paste("Before", row$psStrategy)), + th(colspan = 3, class = "dt-center", paste("After", row$psStrategy)) + ), + tr( + lapply(table1[1, 2:ncol(table1)], th) + ), + tr( + lapply(table1[2, 2:ncol(table1)], th) + ) + ) + )) + options <- list(columnDefs = list(list(className = 'dt-right', targets = 1:6)), + searching = FALSE, + ordering = FALSE, + paging = FALSE, + bInfo = FALSE) + table1 <- datatable(table1[3:nrow(table1), ], + options = options, + rownames = FALSE, + escape = FALSE, + container = container, + class = "stripe nowrap compact") + return(table1) + } + }) + + output$psDistPlot <- renderPlot({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + targetId <- unique(exposures$exposureId[exposures$exposureName == input$target]) + comparatorId <- unique(exposures$exposureId[exposures$exposureName == input$comparator]) + outcomeId <- unique(outcomes$outcomeId[outcomes$outcomeName == input$outcome]) + ps <- getPs(connection = connection, + targetId = targetId, + comparatorId = comparatorId, + databaseId = row$databaseId) + plot <- plotPs(ps, input$target, input$comparator) + return(plot) + } + }) + + output$balancePlot <- renderPlot({ + bal <- balance() + if (is.null(bal)) { + return(NULL) + } else { + row <- selectedRow() + writeLines("Plotting covariate balance") + plot <- plotCovariateBalanceScatterPlot(balance = bal, + beforeLabel = paste("Before", row$psStrategy), + afterLabel = paste("Before", row$psStrategy)) + return(plot) + } + }) + + output$balancePlotCaption <- renderUI({ + bal <- balance() + if (is.null(bal)) { + return(NULL) + } else { + row <- selectedRow() + text <- "Figure 3. Covariate balance before and after %s. Each dot represents + the standardizes difference of means for a single covariate before and after %s on the propensity + score. Move the mouse arrow over a dot for more details." + return(HTML(sprintf(text, row$psStrategy, row$psStrategy))) + } + }) + + output$hoverInfoBalanceScatter <- renderUI({ + bal <- balance() + if (is.null(bal)) { + return(NULL) + } else { + row <- selectedRow() + hover <- input$plotHoverBalanceScatter + point <- nearPoints(bal, hover, threshold = 5, maxpoints = 1, addDist = TRUE) + if (nrow(point) == 0) { + return(NULL) + } + left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left) + top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom) + left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left) + top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top) + style <- paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); ", + "left:", + left_px - 251, + "px; top:", + top_px - 150, + "px; width:500px;") + beforeMatchingStdDiff <- formatC(point$beforeMatchingStdDiff, digits = 2, format = "f") + afterMatchingStdDiff <- formatC(point$afterMatchingStdDiff, digits = 2, format = "f") + div( + style = "position: relative; width: 0; height: 0", + wellPanel( + style = style, + p(HTML(paste0(" Covariate: ", point$covariateName, "
", + " Std. diff before ",tolower(row$psStrategy),": ", beforeMatchingStdDiff, "
", + " Std. diff after ",tolower(row$psStrategy),": ", afterMatchingStdDiff))) + ) + ) + } + }) + + output$systematicErrorPlot <- renderPlot({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + targetId <- unique(exposures$exposureId[exposures$exposureName == input$target]) + comparatorId <- unique(exposures$exposureId[exposures$exposureName == input$comparator]) + controlResults <- getControlResults(connection = connection, + targetId = targetId, + comparatorId = comparatorId, + analysisId = row$analysisId, + databaseId = row$databaseId) + + plot <- plotScatter(controlResults) + return(plot) + } + }) + + output$kaplanMeierPlot <- renderPlot({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + targetId <- unique(exposures$exposureId[exposures$exposureName == input$target]) + comparatorId <- unique(exposures$exposureId[exposures$exposureName == input$comparator]) + outcomeId <- unique(outcomes$outcomeId[outcomes$outcomeName == input$outcome]) + km <- getKaplanMeier(connection = connection, + targetId = targetId, + comparatorId = comparatorId, + outcomeId = outcomeId, + databaseId = row$databaseId, + analysisId = row$analysisId) + plot <- plotKaplanMeier(kaplanMeier = km, + targetName = input$target, + comparatorName = input$comparator) + return(plot) + } + }, res = 100) + + output$kaplanMeierPlotPlotCaption <- renderUI({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + text <- "Figure 5. Kaplan Meier plot, showing survival as a function of time. This plot + is adjusted for the propensity score %s: The target curve (%s) shows the actual observed survival. The + comparator curve (%s) applies reweighting to approximate the counterfactual of what the target survival + would look like had the target cohort been exposed to the comparator instead. The shaded area denotes + the 95 percent confidence interval." + return(HTML(sprintf(text, row$psStrategy, input$target, input$comparator))) + } + }) + + interactionEffects <- reactive({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + targetId <- unique(exposures$exposureId[exposures$exposureName == input$target]) + comparatorId <- unique(exposures$exposureId[exposures$exposureName == input$comparator]) + outcomeId <- unique(outcomes$outcomeId[outcomes$outcomeName == input$outcome]) + analysisIds <- analyses$analysisId[grepl(gsub("PS stratification, ", "", analyses$description[analyses$analysisId == row$analysisId]), analyses$description)] + subgroupResults <- getSubgroupResults(connection = connection, + targetIds = targetId, + comparatorIds = comparatorId, + outcomeIds = outcomeId, + databaseIds = row$databaseId, + analysisIds = analysisIds) + if (nrow(subgroupResults) == 0) { + return(NULL) + } else { + return(subgroupResults) + } + } + }) + + output$subgroupTableCaption <- renderUI({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + text <- "Table 4. Subgroup interactions. For each subgroup, the number of subject within the subroup + in the target (%s) and comparator (%s) cohorts are provided, as well as the hazard ratio ratio (HRR) + with 95 percent confidence interval and p-value (uncalibrated and calibrated) for interaction of the main effect with + the subgroup." + return(HTML(sprintf(text, input$target, input$comparator))) + } + }) + + output$subgroupTable <- renderDataTable({ + row <- selectedRow() + if (is.null(row)) { + return(NULL) + } else { + subgroupResults <- interactionEffects() + if (is.null(subgroupResults)) { + return(NULL) + } + subgroupTable <- prepareSubgroupTable(subgroupResults, output = "html") + colnames(subgroupTable) <- c("Subgroup", + "Target subjects", + "Comparator subjects", + "HRR", + "P", + "Cal.P") + options <- list(searching = FALSE, + ordering = FALSE, + paging = FALSE, + bInfo = FALSE) + subgroupTable <- datatable(subgroupTable, + options = options, + rownames = FALSE, + escape = FALSE, + class = "stripe nowrap compact") + return(subgroupTable) + } + }) + + # Main effects tab --------------------------------------------------------------------------- + observe({ + indicationId <- input$meIndication + if (indicationId == "All") { + updateSelectInput(session = session, + inputId = "meExposureGroup", + choices = c("All", unique(exposureGroups$exposureGroup))) + } else { + updateSelectInput(session = session, + inputId = "meExposureGroup", + choices = c("All", unique(exposureGroups$exposureGroup[exposureGroups$indicationId == indicationId]))) + } + }) + + observe({ + indicationId <- input$meIndication + exposureGroup <- input$meExposureGroup + if (indicationId == "All") { + filteredExposures <- exposures + filteredOutcomes <- outcomes + } else { + filteredExposures <- exposures[exposures$indicationId == indicationId, ] + filteredOutcomes <- outcomes[outcomes$indicationId == indicationId, ] + } + if (exposureGroup == "All") { + filteredExposures <- filteredExposures + } else { + filteredExposures <- filteredExposures[filteredExposures$exposureGroup == exposureGroup, ] + } + updateSelectInput(session = session, + inputId = "meTarget", + choices = c("All", unique(filteredExposures$exposureName))) + updateSelectInput(session = session, + inputId = "meComparator", + choices = c("All", unique(filteredExposures$exposureName))) + updateSelectInput(session = session, + inputId = "meOutcome", + choices = c("All", unique(filteredOutcomes$outcomeName))) + }) + + output$mePlot <- renderPlot({ + indicationId <- input$meIndication + exposureGroup <- input$meExposureGroup + if (indicationId == "All") { + filteredExposures <- exposures + filteredOutcomes <- outcomes + } else { + filteredExposures <- exposures[exposures$indicationId == indicationId, ] + filteredOutcomes <- outcomes[outcomes$indicationId == indicationId, ] + } + if (exposureGroup == "All") { + filteredExposures <- filteredExposures + } else { + filteredExposures <- filteredExposures[filteredExposures$exposureGroup == exposureGroup, ] + } + target <- input$meTarget + if (target == "All") { + targetIds <- unique(filteredExposures$exposureId) + } else { + targetIds <- unique(filteredExposures$exposureId[filteredExposures$exposureName == target]) + } + comparator <- input$meComparator + if (comparator == "All") { + comparatorIds <- unique(filteredExposures$exposureId) + } else { + comparatorIds <- unique(filteredExposures$exposureId[filteredExposures$exposureName == comparator]) + } + outcome <- input$meOutcome + if (outcome == "All") { + outcomeIds <- unique(filteredOutcomes$outcomeId) + } else { + outcomeIds <- unique(filteredOutcomes$outcomeId[filteredOutcomes$outcomeName == outcome]) + } + database <- input$meDatabase + if (database == "All") { + databaseIds <- databases$databaseId + } else { + databaseIds <- database + } + analysis <- input$meAnalysis + if (analysis == "All") { + analysisIds <- 1:4 + } else { + analysisIds <- analyses$analysisId[analyses$description == analysis] + } + writeLines("Fetching main effects") + mainEffects <- getMainResults(connection = connection, + targetIds = targetIds, + comparatorIds = comparatorIds, + outcomeIds = outcomeIds, + databaseIds = databaseIds, + analysisIds = analysisIds, + estimatesOnly = TRUE) + mainEffects <- data.frame(logRr = mainEffects$calibratedLogRr, + seLogRr = mainEffects$calibratedSeLogRr, + ci95lb = mainEffects$calibratedCi95Lb, + ci95ub = mainEffects$calibratedCi95Ub) + writeLines("Plotting main effects") + plot <- plotLargeScatter(mainEffects, "Calibrated hazard ratio") + return(plot) + }, width = 1000 , height = 500) + + # Interaction effects tab --------------------------------------------------------------------------- + observe({ + indicationId <- input$ieIndication + if (indicationId == "All") { + updateSelectInput(session = session, + inputId = "ieExposureGroup", + choices = c("All", unique(exposureGroups$exposureGroup))) + } else { + updateSelectInput(session = session, + inputId = "ieExposureGroup", + choices = c("All", unique(exposureGroups$exposureGroup[exposureGroups$indicationId == indicationId]))) + } + }) + + observe({ + indicationId <- input$ieIndication + exposureGroup <- input$ieExposureGroup + if (indicationId == "All") { + filteredExposures <- exposures + filteredOutcomes <- outcomes + } else { + filteredExposures <- exposures[exposures$indicationId == indicationId, ] + filteredOutcomes <- outcomes[outcomes$indicationId == indicationId, ] + } + if (exposureGroup == "All") { + filteredExposures <- filteredExposures + } else { + filteredExposures <- filteredExposures[filteredExposures$exposureGroup == exposureGroup, ] + } + updateSelectInput(session = session, + inputId = "ieTarget", + choices = c("All", unique(filteredExposures$exposureNaie))) + updateSelectInput(session = session, + inputId = "ieComparator", + choices = c("All", unique(filteredExposures$exposureNaie))) + updateSelectInput(session = session, + inputId = "ieOutcome", + choices = c("All", unique(filteredOutcomes$outcomeNaie))) + }) + + output$iePlot <- renderPlot({ + indicationId <- input$ieIndication + exposureGroup <- input$ieExposureGroup + if (indicationId == "All") { + filteredExposures <- exposures + filteredOutcomes <- outcomes + } else { + filteredExposures <- exposures[exposures$indicationId == indicationId, ] + filteredOutcomes <- outcomes[outcomes$indicationId == indicationId, ] + } + if (exposureGroup == "All") { + filteredExposures <- filteredExposures + } else { + filteredExposures <- filteredExposures[filteredExposures$exposureGroup == exposureGroup, ] + } + target <- input$ieTarget + if (target == "All") { + targetIds <- unique(filteredExposures$exposureId) + } else { + targetIds <- unique(filteredExposures$exposureId[filteredExposures$exposureNaie == target]) + } + comparator <- input$ieComparator + if (comparator == "All") { + comparatorIds <- unique(filteredExposures$exposureId) + } else { + comparatorIds <- unique(filteredExposures$exposureId[filteredExposures$exposureNaie == comparator]) + } + outcome <- input$ieComparator + if (outcome == "All") { + outcomeIds <- unique(filteredOutcomes$outcomeId) + } else { + outcomeIds <- unique(filteredOutcomes$outcomeId[filteredOutcomes$outcomeNaie == outcome]) + } + database <- input$ieDatabase + if (database == "All") { + databaseIds <- databases$databaseId + } else { + databaseIds <- database + } + analysis <- input$ieAnalysis + if (analysis == "All") { + analysisIds <- c() + } else { + analysisIds <- analyses$analysisId[grepl(gsub("PS stratification, ", "", analysis), analyses$description)] + } + subgroup <- input$ieSubgroup + if (subgroup == "All") { + subgroupIds <- subgroups$subgroupId + } else { + subgroupIds <- subgroups$subgroupId[subgroups$subgroupName == subgroup] + } + + writeLines("Fetching interaction effects") + interactionEffects <- getSubgroupResults(connection = connection, + targetIds = targetIds, + comparatorIds = comparatorIds, + outcomeIds = outcomeIds, + databaseIds = databaseIds, + analysisIds = analysisIds, + subgroupIds = subgroupIds, + estimatesOnly = TRUE) + interactionEffects <- data.frame(logRr = interactionEffects$logRrr, + seLogRr = interactionEffects$seLogRrr, + ci95lb = interactionEffects$ci95Lb, + ci95ub = interactionEffects$ci95Ub) + writeLines("Plotting interaction effects") + plot <- plotLargeScatter(interactionEffects, "Uncalibrated hazard ratio ratio") + return(plot) + }, width = 1000 , height = 500) + + + # Propensity scores tab --------------------------------------------------------------------------- + observe({ + indicationId <- input$psIndication + updateSelectInput(session = session, + inputId = "psExposureGroup", + choices = unique(exposureGroups$exposureGroup[exposureGroups$indicationId == indicationId])) + }) + + observe({ + indicationId <- input$psIndication + exposureGroup <- input$psExposureGroup + filteredExposures <- exposures[exposures$indicationId == indicationId, ] + filteredOutcomes <- outcomes[outcomes$indicationId == indicationId, ] + filteredExposures <- filteredExposures[filteredExposures$exposureGroup == exposureGroup, ] + updateSelectInput(session = session, + inputId = "psTarget", + choices = c("All", unique(filteredExposures$exposureName))) + updateSelectInput(session = session, + inputId = "psComparator", + choices = c("All", unique(filteredExposures$exposureName))) + }) + + output$psPlot <- renderPlot({ + indicationId <- input$psIndication + exposureGroup <- input$psExposureGroup + filteredExposures <- exposures[exposures$indicationId == indicationId, ] + filteredExposures <- filteredExposures[filteredExposures$exposureGroup == exposureGroup, ] + target <- input$psTarget + if (target == "All") { + targetIds <- unique(filteredExposures$exposureId) + } else { + targetIds <- unique(filteredExposures$exposureId[filteredExposures$exposureName == target]) + } + comparator <- input$psComparator + if (comparator == "All") { + comparatorIds <- unique(filteredExposures$exposureId) + } else { + comparatorIds <- unique(filteredExposures$exposureId[filteredExposures$exposureName == comparator]) + } + databaseId <- input$psDatabase + writeLines("Fetching PS distributions") + ps <- getPs(connection = connection, + targetIds = targetIds, + comparatorIds = comparatorIds, + databaseId = databaseId) + if (nrow(ps) == 0) { + return(NULL) + } + ps <- merge(ps, data.frame(targetId = exposures$exposureId, + targetName = exposures$exposureName)) + ps <- merge(ps, data.frame(comparatorId = exposures$exposureId, + comparatorName = exposures$exposureName)) + writeLines("Plotting PS distributions") + plot <- plotAllPs(ps) + return(plot) + }, width = 1000 , height = 600) +}) + +onStop(function() { + writeLines("Closing connection") + DatabaseConnector::disconnect(connection) +}) diff --git a/LegendBasicViewer/ui.R b/LegendBasicViewer/ui.R new file mode 100644 index 00000000..035c2049 --- /dev/null +++ b/LegendBasicViewer/ui.R @@ -0,0 +1,137 @@ +library(shiny) +library(DT) + +shinyUI( + fluidPage(style = "width:1500px;", + titlePanel("LEGEND basic viewer"), + tags$head(tags$style(type = "text/css", " + #loadmessage { + position: fixed; + top: 0px; + left: 0px; + width: 100%; + padding: 5px 0px 5px 0px; + text-align: center; + font-weight: bold; + font-size: 100%; + color: #000000; + background-color: #ADD8E6; + z-index: 105; + } + ")), + conditionalPanel(condition = "$('html').hasClass('shiny-busy')", + tags$div("Procesing...",id = "loadmessage")), + tabsetPanel(id = "mainTabsetPanel", + tabPanel("About", + HTML("

This app is under development. All results are preliminary and may change without notice.

"), + HTML("

Do not use.

") + ), + tabPanel("Specific research questions", + fluidRow( + column(3, + selectInput("indication", "Indication", indications$indicationId, selected = "Hypertension"), + selectInput("exposureGroup", "Exposure group", unique(exposureGroups$exposureGroup), selected = "Drug major class"), + selectInput("target", "Target", unique(exposures$exposureName), selected = "Calcium channel blockers (CCB)"), + selectInput("comparator", "Comparator", unique(exposures$exposureName), selected = "Beta blockers"), + selectInput("outcome", "Outcome", unique(outcomes$outcomeName)), + checkboxGroupInput("database", "Data source", databases$databaseId, selected = databases$databaseId), + checkboxGroupInput("analysis", "Analysis", analyses$description[analyses$analysisId <= 4], selected = analyses$description[analyses$analysisId <= 4]) + ), + column(9, + dataTableOutput("mainTable"), + conditionalPanel("output.rowIsSelected == true", + tabsetPanel(id = "detailsTabsetPanel", + tabPanel("Power", + uiOutput("powerTableCaption"), + tableOutput("powerTable"), + uiOutput("timeAtRiskTableCaption"), + tableOutput("timeAtRiskTable") + ), + tabPanel("Attrition", + plotOutput("attritionPlot", width = 600, height = 600), + uiOutput("attritionPlotCaption") + ), + tabPanel("Population characteristics", + uiOutput("table1Caption"), + dataTableOutput("table1Table")), + tabPanel("Propensity scores", + plotOutput("psDistPlot"), + div(strong("Figure 2."),"Preference score distribution. The preference score is a transformation of the propensity score + that adjusts for differences in the sizes of the two treatment groups. A higher overlap indicates subjects in the + two groups were more similar in terms of their predicted probability of receiving one treatment over the other.")), + tabPanel("Covariate balance", + uiOutput("hoverInfoBalanceScatter"), + plotOutput("balancePlot", + hover = hoverOpts("plotHoverBalanceScatter", delay = 100, delayType = "debounce")), + uiOutput("balancePlotCaption")), + tabPanel("Systematic error", + plotOutput("systematicErrorPlot"), + div(strong("Figure 4."),"Systematic error. Effect size estimates for the negative controls (true hazard ratio = 1) + and positive controls (true hazard ratio > 1), before and after calibration. Estimates below the diagonal dashed + lines are statistically significant (alpha = 0.05) different from the true effect size. A well-calibrated + estimator should have the true effect size within the 95 percent confidence interval 95 percent of times.")), + tabPanel("Kaplan-Meier", + plotOutput("kaplanMeierPlot", height = 550), + uiOutput("kaplanMeierPlotPlotCaption")), + tabPanel("Subgroups", + uiOutput("subgroupTableCaption"), + dataTableOutput("subgroupTable")) + ) + ) + ) + + ) + ), + tabPanel("Overview", + tabsetPanel(id = "overviewTabsetPanel", + tabPanel("Main effects", + fluidRow( + column(3, + selectInput("meIndication", "Indication", c("All", indications$indicationId)), + selectInput("meExposureGroup", "Exposure group", c("All", unique(exposureGroups$exposureGroup))), + selectInput("meTarget", "Target", c("All", unique(exposures$exposureName))), + selectInput("meComparator", "Comparator", c("All", unique(exposures$exposureName))), + selectInput("meOutcome", "Outcome", c("All", unique(outcomes$outcomeName))), + selectInput("meDatabase", "Database", c("All", databases$databaseId)), + selectInput("meAnalysis", "Analysis", c("All", analyses$description[analyses$analysisId <= 4])) + ), + column(9, + plotOutput("mePlot") + ) + ) + ), + tabPanel("Interaction effects", + column(3, + selectInput("ieIndication", "Indication", c("All", indications$indicationId)), + selectInput("ieExposureGroup", "Exposure group", c("All", unique(exposureGroups$exposureGroup))), + selectInput("ieTarget", "Target", c("All", unique(exposures$exposureName))), + selectInput("ieComparator", "Comparator", c("All", unique(exposures$exposureName))), + selectInput("ieOutcome", "Outcome", c("All", unique(outcomes$outcomeName))), + selectInput("ieSubgroup", "Subgroup", c("All", subgroups$subgroupName)), + selectInput("ieDatabase", "Database", c("All", databases$databaseId)), + selectInput("ieAnalysis", "Analysis", c("All", analyses$description[analyses$analysisId <= 2])) + ), + column(9, + plotOutput("iePlot") + ) + ), + tabPanel("Propensity score distributions", + fluidRow( + column(3, + selectInput("psIndication", "Indication", indications$indicationId), + selectInput("psExposureGroup", "Exposure group", unique(exposureGroups$exposureGroup)), + selectInput("psTarget", "Target", c("All", unique(exposures$exposureName))), + selectInput("psComparator", "Comparator", c("All", unique(exposures$exposureName))), + selectInput("psDatabase", "Database", databases$databaseId) + ), + column(9, + plotOutput("psPlot") + ) + ) + + ) + ) + ) + ) + ) +)