Skip to content

Commit

Permalink
Merge pull request #257 from USEPA/235-247-248-206-API-plotting-and-b…
Browse files Browse the repository at this point in the history 
…ug-fixes

235 247 248 206 api plotting and bug fixes
  • Loading branch information
@cthunes
cthunes authored Jun 10, 2024
2 parents 4c7fe0c + 216e7d4 commit bc90593
Show file tree
Hide file tree
Showing 6 changed files with 172 additions and 109 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -60,7 +60,7 @@ Suggests:
vdiffr
License: MIT + file LICENSE
LazyData: true
RoxygenNote: 7.2.3
RoxygenNote: 7.3.1
VignetteBuilder: knitr
Encoding: UTF-8
Config/testthat/edition: 3
1 change: 1 addition & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -157,6 +157,7 @@ importFrom(tcplfit2,tcplhit2_core)
importFrom(tidyr,pivot_longer)
importFrom(tidyr,pivot_wider)
importFrom(tidyr,separate_wider_delim)
importFrom(tidyr,unnest)
importFrom(tidyr,unnest_longer)
importFrom(utils,data)
importFrom(utils,read.csv)
Expand Down
205 changes: 129 additions & 76 deletions R/tcplPlot.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -68,7 +68,7 @@ tcplPlot <- function(dat = NULL, type = "mc", fld = "m4id", val = NULL, compare.
list2env(validated_vars, envir = environment())

# check_tcpl_db_schema is a user-defined function found in v3_schema_functions.R file
if (check_tcpl_db_schema() | !is.null(dat)) {
if (check_tcpl_db_schema() | !is.null(dat) | getOption("TCPL_DRVR") == "API") {
# check if user supplied data. If not, load from db connection
if(is.null(dat)){
dat <- tcplPlotLoadData(lvl = lvl, fld = fld, val = val, type = type,flags = flags, compare = FALSE) #code defined in tcplPlotUtils.R
Expand Down Expand Up @@ -114,7 +114,7 @@ tcplPlot <- function(dat = NULL, type = "mc", fld = "m4id", val = NULL, compare.
nrow = ncol = 1
}
# error message for output="console" and multi=FALSE to avoid multiple plots in console
if(nrow(dat) > 1 && output == "console" && multi == FALSE) stop("More than 1 concentration series returned for given field/val combination. Set output to pdf or reduce the number of curves to 1. Current number of curves: ", nrow(input))
if(nrow(dat[compare == FALSE]) != 1 && output == "console" && multi == FALSE) stop("More than 1 concentration series returned for given field/val combination. Set output to pdf or reduce the number of curves to 1. Current number of curves: ", nrow(dat))
if(is.null(nrow)){
nrow <- ifelse(verbose,2,2)
}
Expand All @@ -132,7 +132,7 @@ tcplPlot <- function(dat = NULL, type = "mc", fld = "m4id", val = NULL, compare.
# tcplPlotlyplot is the user-defined function found in tcplPlot.R file used to connect tcpl and plotly packages
# tcplggplot is the user-defined function found in tcplPlot.R file used to connect tcpl and ggplot2 packages
return(tcplPlotlyPlot(dat, lvl)),
return(ggsave(filename=paste0(fileprefix,"_",paste0(dat$m4id, collapse = "_"),".",output),
return(ggsave(filename=paste0(fileprefix,"_",paste0(ifelse(type=="mc",dat$m4id,dat$s2id), collapse = "_"),".",output),
plot= if(is.null(compare.val)) tcplggplot(dat,verbose = verbose, lvl = lvl, flags = flags, yrange = yrange) else tcplggplotCompare(dat[compare == FALSE],dat[compare == TRUE],verbose = verbose, lvl = lvl, flags = flags, yrange = yrange), width = 7, height = 5, dpi=dpi))
)
} else {
Expand Down Expand Up @@ -399,6 +399,22 @@ tcplPlotlyPlot <- function(dat, lvl = 5){
}
}

} else if (lvl == 2) { #single conc
# main data
if (!is.null(dat$coff) && dat$max_med < 0) {
dat$coff <- dat$coff * -1
}
if (!is.null(dat$coff) && !is.null(dat$hitc) && dat$hitc < 0) {
dat$coff <- dat$coff * -1
}

# compare data
if (!is.null(compare.dat$coff) && compare.dat$max_med < 0) {
compare.dat$coff <- compare.dat$coff * -1
}
if (!is.null(compare.dat$coff) && !is.null(compare.dat$hitc) && compare.dat$hitc < 0) {
compare.dat$coff <- compare.dat$coff * -1
}
}

# function for truncating decimals
Expand Down Expand Up @@ -500,7 +516,7 @@ tcplPlotlyPlot <- function(dat, lvl = 5){
inherit = FALSE,
hoverinfo = "text",
text = ~ paste(
"</br>", paste0("Cut Off B (", specify_decimal(dat$coff,2), ")")
"</br>", paste0("Cut Off B (", specify_decimal(compare.dat$coff,2), ")")
)
)
}
Expand Down Expand Up @@ -831,37 +847,47 @@ tcplggplot <- function(dat, lvl = 5, verbose = FALSE, flags = FALSE, yrange = c(
range()

# check if model_type is 3 or 4, which means an override method was assigned
if (lvl == 5 && dat$model_type == 3) { # gain direction
# leave coff but bmr should flip if top is negative
if (!is.null(dat$top) && !is.na(dat$top) && !is.null(dat$bmr)) {
if (dat$top < 0) {
dat$bmr <- dat$bmr * -1
if (lvl == 5) {
if (dat$model_type == 3) { # gain direction
# leave coff but bmr should flip if top is negative
if (!is.null(dat$top) && !is.na(dat$top) && !is.null(dat$bmr)) {
if (dat$top < 0) {
dat$bmr <- dat$bmr * -1
}
}
} else if (dat$model_type == 4) { # loss direction
# coff and bmr(if top < 0) should be negative
if (!is.null(dat$top) && !is.null(dat$coff) && !is.na(dat$top) && !is.null(dat$bmr)) {
dat$coff <- dat$coff * -1
if (dat$top < 0) {
dat$bmr <- dat$bmr * -1
}
}
} else { # bidirectional
# check if winning model has negative top. If so coff,bmr should be negative
if (!is.null(dat$top) && !is.null(dat$coff) && !is.na(dat$top) && !is.null(dat$bmr)) {
if (dat$top < 0) {
dat$coff <- dat$coff * -1
dat$bmr <- dat$bmr * -1
}
}
}
} else if (lvl == 5 && dat$model_type == 4) { # loss direction
# coff and bmr(if top < 0) should be negative
if (!is.null(dat$top) && !is.null(dat$coff) && !is.na(dat$top) && !is.null(dat$bmr)) {
} else { #single conc
if (!is.null(dat$coff) && dat$max_med < 0) {
dat$coff <- dat$coff * -1
if (dat$top < 0) {
dat$bmr <- dat$bmr * -1
}
}
} else { # bidirectional
# check if winning model has negative top. If so coff,bmr should be negative
if (!is.null(dat$top) && !is.null(dat$coff) && !is.na(dat$top) && !is.null(dat$bmr)) {
if (dat$top < 0) {
dat$coff <- dat$coff * -1
dat$bmr <- dat$bmr * -1
}
if (!is.null(dat$coff) && !is.null(dat$hitc) && dat$hitc < 0) {
dat$coff <- dat$coff * -1
}
}


# check if ac50 is null and assign NA if it is
dat$ac50 <- ifelse(is.null(dat$ac50), NA, dat$ac50)

# check if dtxsid is NA, pull wllt in from lvl 3
if (is.na(dat$dsstox_substance_id) | is.na(dat$chnm)) {
wllt <- unique(tcplLoadData(lvl = 0, fld = list("spid","acid"),
if (getOption("TCPL_DRVR") != "API" && (is.na(dat$dsstox_substance_id) | is.na(dat$chnm))) {
wllt <- unique(tcplLoadData(type = ifelse(lvl == 2, "sc", "mc"), lvl = 0, fld = list("spid","acid"),
list(dat$spid, tcplLoadAcid(fld = "aeid", val = dat$aeid)$acid))$wllt)
if (length(wllt) == 1) {
if (wllt == 'c' | wllt == 'p') {
Expand All @@ -885,13 +911,18 @@ tcplggplot <- function(dat, lvl = 5, verbose = FALSE, flags = FALSE, yrange = c(
dat$chnm <- ""
}
else {
data$dsstox_substance_id <- paste0("Well type: ", wllt)
data$chnm <- ""
dat$dsstox_substance_id <- paste0("Well type: ", wllt)
dat$chnm <- ""
}
}
else {
warning(paste0("wllt for SPID: ", dat$spid, " is missing or length > 1.
if (length(wllt) > 1) {
dat$dsstox_substance_id <- paste0("Well type: ", paste(wllt, collapse = ", "))
dat$chnm <- ""
} else {
warning(paste0("wllt for SPID: ", dat$spid, " is missing.
Leaving dsstox_substance_id and chnm as NA."))
}
}
}

Expand All @@ -915,7 +946,7 @@ tcplggplot <- function(dat, lvl = 5, verbose = FALSE, flags = FALSE, yrange = c(
if (lvl == 2) {
gg <- ggplot(l3_dat, aes(x = conc)) +
geom_hline(aes(yintercept = dat$max_med, linetype = "Max Median"), color="red") +
geom_hline(aes(yintercept = ifelse(dat$max_med >= 0, dat$coff, dat$coff * -1), linetype="Cutoff"), color="blue") +
geom_hline(aes(yintercept = dat$coff, linetype="Cutoff"), color="blue") +
geom_point(aes(y = resp)) +
scale_x_continuous(limits = l3_range, trans = ifelse(0 %in% l3_dat$conc,"identity","log10")) +
scale_y_continuous(limits = yrange) +
Expand Down Expand Up @@ -1093,62 +1124,77 @@ tcplggplotCompare <- function(dat, compare.dat, lvl = 5, verbose = FALSE, flags

if (dat$conc_unit != compare.dat$conc_unit || dat$normalized_data_type != compare.dat$normalized_data_type) stop("Units do not match.")

# main data
# check if model_type is 3 or 4, which means an override method was assigned
if (lvl == 5 && dat$model_type == 3) { # gain direction
# leave coff but bmr should flip if top is negative
if (!is.null(dat$top) && !is.na(dat$top) && !is.null(dat$bmr)) {
if (dat$top < 0) {
dat$bmr <- dat$bmr * -1
}
}
} else if (lvl == 5 && dat$model_type == 4) { # loss direction
# coff and bmr(if top < 0) should be negative
if (!is.null(dat$top) && !is.null(dat$coff) && !is.na(dat$top) && !is.null(dat$bmr)) {
dat$coff <- dat$coff * -1
if (dat$top < 0) {
dat$bmr <- dat$bmr * -1
if (lvl == 5) {
# main data
if (dat$model_type == 3) { # gain direction
# leave coff but bmr should flip if top is negative
if (!is.null(dat$top) && !is.na(dat$top) && !is.null(dat$bmr)) {
if (dat$top < 0) {
dat$bmr <- dat$bmr * -1
}
}
}
} else { # bidirectional
# check if winning model has negative top. If so coff,bmr should be negative
if (!is.null(dat$top) && !is.null(dat$coff) && !is.na(dat$top) && !is.null(dat$bmr)) {
if (dat$top < 0) {
} else if (dat$model_type == 4) { # loss direction
# coff and bmr(if top < 0) should be negative
if (!is.null(dat$top) && !is.null(dat$coff) && !is.na(dat$top) && !is.null(dat$bmr)) {
dat$coff <- dat$coff * -1
dat$bmr <- dat$bmr * -1
if (dat$top < 0) {
dat$bmr <- dat$bmr * -1
}
}
}
}

# compare data
# check if model_type is 3 or 4, which means an override method was assigned
if (lvl == 5 && compare.dat$model_type == 3) { # gain direction
# leave coff but bmr should flip if top is negative
if (!is.null(compare.dat$top) && !is.na(compare.dat$top) && !is.null(compare.dat$bmr)) {
if (compare.dat$top < 0) {
compare.dat$bmr <- compare.dat$bmr * -1
} else { # bidirectional
# check if winning model has negative top. If so coff,bmr should be negative
if (!is.null(dat$top) && !is.null(dat$coff) && !is.na(dat$top) && !is.null(dat$bmr)) {
if (dat$top < 0) {
dat$coff <- dat$coff * -1
dat$bmr <- dat$bmr * -1
}
}
}
} else if (lvl == 5 && compare.dat$model_type == 4) { # loss direction
# coff and bmr(if top < 0) should be negative
if (!is.null(compare.dat$top) && !is.null(compare.dat$coff) && !is.na(compare.dat$top) && !is.null(compare.dat$bmr)) {
compare.dat$coff <- compare.dat$coff * -1
if (compare.dat$top < 0) {
compare.dat$bmr <- compare.dat$bmr * -1

# compare data
if (compare.dat$model_type == 3) { # gain direction
# leave coff but bmr should flip if top is negative
if (!is.null(compare.dat$top) && !is.na(compare.dat$top) && !is.null(compare.dat$bmr)) {
if (compare.dat$top < 0) {
compare.dat$bmr <- compare.dat$bmr * -1
}
}
}
} else { # bidirectional
# check if winning model has negative top. If so coff,bmr should be negative
if (!is.null(compare.dat$top) && !is.null(compare.dat$coff) && !is.na(compare.dat$top) && !is.null(compare.dat$bmr)) {
if (compare.dat$top < 0) {
} else if (compare.dat$model_type == 4) { # loss direction
# coff and bmr(if top < 0) should be negative
if (!is.null(compare.dat$top) && !is.null(compare.dat$coff) && !is.na(compare.dat$top) && !is.null(compare.dat$bmr)) {
compare.dat$coff <- compare.dat$coff * -1
compare.dat$bmr <- compare.dat$bmr * -1
if (compare.dat$top < 0) {
compare.dat$bmr <- compare.dat$bmr * -1
}
}
} else { # bidirectional
# check if winning model has negative top. If so coff,bmr should be negative
if (!is.null(compare.dat$top) && !is.null(compare.dat$coff) && !is.na(compare.dat$top) && !is.null(compare.dat$bmr)) {
if (compare.dat$top < 0) {
compare.dat$coff <- compare.dat$coff * -1
compare.dat$bmr <- compare.dat$bmr * -1
}
}
}
} else { #single conc
# main data
if (!is.null(dat$coff) && dat$max_med < 0) {
dat$coff <- dat$coff * -1
}
if (!is.null(dat$coff) && !is.null(dat$hitc) && dat$hitc < 0) {
dat$coff <- dat$coff * -1
}

# compare data
if (!is.null(compare.dat$coff) && compare.dat$max_med < 0) {
compare.dat$coff <- compare.dat$coff * -1
}
if (!is.null(compare.dat$coff) && !is.null(compare.dat$hitc) && compare.dat$hitc < 0) {
compare.dat$coff <- compare.dat$coff * -1
}
}



# check if data is outside bounds of yrange. If so, expand yrange bounds
if (!identical(yrange, c(NA,NA))) {
yrange[1] <- min(dat$resp_min, dat$coff, yrange[1], unlist(dat$resp),
Expand All @@ -1160,7 +1206,7 @@ tcplggplotCompare <- function(dat, compare.dat, lvl = 5, verbose = FALSE, flags
check_wllt <- function(data) {
# check if dtxsid is NA, pull wllt in from lvl 3
if (is.na(data$dsstox_substance_id) | is.na(data$chnm)) {
wllt <- unique(tcplLoadData(lvl = 0, fld = list("spid","acid"),
wllt <- unique(tcplLoadData(type = ifelse(lvl == 2, "sc", "mc"), lvl = 0, fld = list("spid","acid"),
list(data$spid, tcplLoadAcid(fld = "aeid", val = data$aeid)$acid))$wllt)
if (length(wllt) == 1) {
if (wllt == 'c' | wllt == 'p') {
Expand Down Expand Up @@ -1189,14 +1235,21 @@ tcplggplotCompare <- function(dat, compare.dat, lvl = 5, verbose = FALSE, flags
}
}
else {
warning(paste0("wllt for SPID: ", data$spid, " is missing or length > 1.
if (length(wllt) > 1) {
data$dsstox_substance_id <- paste0("Well type: ", paste(wllt, collapse = ", "))
data$chnm <- ""
} else {
warning(paste0("wllt for SPID: ", data$spid, " is missing.
Leaving dsstox_substance_id and chnm as NA."))
}
}
}
return(data)
}
dat <- check_wllt(dat)
compare.dat <- check_wllt(compare.dat)
if (getOption("TCPL_DRVR") != "API") {
dat <- check_wllt(dat)
compare.dat <- check_wllt(compare.dat)
}

dat$winning_model_string <- paste0("Model A(", dat$modl, ")")
compare.dat$winning_model_string <- paste0("Model B(", compare.dat$modl, ")")
Expand Down
Loading

0 comments on commit bc90593

Please sign in to comment.