├── .Rinstignore ├── .github ├── .gitignore └── workflows │ ├── pkgdown.yaml │ ├── R-CMD-check.yaml │ └── test-coverage.yaml ├── tests ├── testthat.R └── testthat │ ├── Rplots.pdf │ ├── guiFiles │ ├── gui_bad_input.csv │ ├── gui_output_data.csv │ ├── gui_output_missingFuncs.csv │ ├── gui_output_nonNumeric.csv │ └── gui_test_data.csv │ ├── test-TxpTransFunc.R │ ├── test-txpImportGui.R │ ├── test-txpExportGui.R │ ├── test-TxpModelList.R │ ├── test-TxpTransFuncList.R │ ├── test-TxpSliceList.R │ ├── test-TxpSlice.R │ ├── test-vsGuiResults.R │ ├── test-TxpModel.R │ ├── test-TxpResultList.R │ └── test-TxpResult.R ├── _pkgdown.yml ├── man ├── figures │ ├── logo-hex.png │ ├── logo-banner.png │ ├── logo-favicon.svg │ └── logo-banner.svg ├── txpImportGui.Rd ├── boxLegendGrob.Rd ├── pieGrob.Rd ├── txpGenerics.Rd ├── TxpResultParam-class.Rd ├── TxpTransFunc-class.Rd ├── txpExportGui.Rd ├── toxpiR-datasets.Rd ├── toxpiR-package.Rd ├── TxpResultList-class.Rd ├── TxpTransFuncList-class.Rd ├── TxpModelList-class.Rd ├── pieGridGrob.Rd ├── TxpSliceList-class.Rd ├── txpCalculateScores.Rd ├── TxpSlice-class.Rd ├── TxpModel-class.Rd ├── TxpResult-plot.Rd └── TxpResult-class.Rd ├── data ├── txp_example_input.rda └── txp_example_model.rda ├── pkgdown └── favicon │ ├── favicon.ico │ ├── favicon-16x16.png │ ├── favicon-32x32.png │ ├── apple-touch-icon.png │ ├── apple-touch-icon-60x60.png │ ├── apple-touch-icon-76x76.png │ ├── apple-touch-icon-120x120.png │ ├── apple-touch-icon-152x152.png │ └── apple-touch-icon-180x180.png ├── vignettes ├── embeddedFigures │ ├── txp_PDF.pdf │ ├── gui_format.JPG │ ├── txp_explain.png │ ├── txp_explain1.png │ ├── coord_munch_new.png │ └── coord_munch_orig.png ├── importFromGui.Rmd └── exportToGui.rmd ├── .gitignore ├── .Rbuildignore ├── man-roxygen ├── roxgn-loadExamples.R ├── roxgn-calcTxpModel.R └── roxgn-calcTxpModelList.R ├── codecov.yml ├── NEWS.md ├── R ├── methods-NamedList.R ├── plotting-boxLegendGrob.R ├── toxpiR-package.R ├── allGenerics.R ├── methods-TxpResultList.R ├── methods-TxpResultParam.R ├── utils.R ├── plotting-annScatterGrob.R ├── methods-TxpTransFuncList.R ├── txpCalculateScores.R ├── allClasses.R ├── methods-TxpSliceList.R ├── methods-TxpTransFunc.R ├── plotting-pieGrob.R ├── methods-TxpModelList.R ├── txpImportGui.R ├── methods-TxpSlice.R ├── txpExportGui.R ├── plotting-pieGridGrob.R └── methods-TxpModel.R ├── README.md ├── DESCRIPTION ├── NAMESPACE └── CONTRIBUTING.md /.Rinstignore: -------------------------------------------------------------------------------- 1 | noBuild -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(toxpiR) 3 | 4 | test_check("toxpiR") 5 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | url: https://toxpi.github.io/toxpiR/ 2 | template: 3 | bootstrap: 5 4 | 5 | -------------------------------------------------------------------------------- /man/figures/logo-hex.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/man/figures/logo-hex.png -------------------------------------------------------------------------------- /tests/testthat/Rplots.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/tests/testthat/Rplots.pdf -------------------------------------------------------------------------------- /data/txp_example_input.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/data/txp_example_input.rda -------------------------------------------------------------------------------- /data/txp_example_model.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/data/txp_example_model.rda -------------------------------------------------------------------------------- /man/figures/logo-banner.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/man/figures/logo-banner.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/pkgdown/favicon/favicon.ico -------------------------------------------------------------------------------- /pkgdown/favicon/favicon-16x16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/pkgdown/favicon/favicon-16x16.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon-32x32.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/pkgdown/favicon/favicon-32x32.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/pkgdown/favicon/apple-touch-icon.png -------------------------------------------------------------------------------- /vignettes/embeddedFigures/txp_PDF.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/vignettes/embeddedFigures/txp_PDF.pdf -------------------------------------------------------------------------------- /vignettes/embeddedFigures/gui_format.JPG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/vignettes/embeddedFigures/gui_format.JPG -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-60x60.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/pkgdown/favicon/apple-touch-icon-60x60.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-76x76.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/pkgdown/favicon/apple-touch-icon-76x76.png -------------------------------------------------------------------------------- /vignettes/embeddedFigures/txp_explain.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/vignettes/embeddedFigures/txp_explain.png -------------------------------------------------------------------------------- /vignettes/embeddedFigures/txp_explain1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/vignettes/embeddedFigures/txp_explain1.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-120x120.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/pkgdown/favicon/apple-touch-icon-120x120.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-152x152.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/pkgdown/favicon/apple-touch-icon-152x152.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-180x180.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/pkgdown/favicon/apple-touch-icon-180x180.png -------------------------------------------------------------------------------- /vignettes/embeddedFigures/coord_munch_new.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/vignettes/embeddedFigures/coord_munch_new.png -------------------------------------------------------------------------------- /vignettes/embeddedFigures/coord_munch_orig.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToxPi/toxpiR/HEAD/vignettes/embeddedFigures/coord_munch_orig.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | *.Rhistory 3 | .RData 4 | .Ruserdata 5 | *.Rproj 6 | *.DS_Store 7 | inst/doc 8 | vignettes/*.html 9 | vignettes/*.R 10 | docs 11 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^codecov\.yml$ 4 | ^\.github$ 5 | ^CONTRIBUTING\.md$ 6 | ^README\.md$ 7 | ^_pkgdown\.yml$ 8 | ^docs$ 9 | ^pkgdown$ 10 | ^LICENSE\.md$ 11 | ^man-roxygen$ 12 | man/figures/logo* -------------------------------------------------------------------------------- /man-roxygen/roxgn-loadExamples.R: -------------------------------------------------------------------------------- 1 | #' @examples 2 | #' ## Load example dataset & model; see ?TxpModel for building model objects 3 | #' data(txp_example_input, package = "toxpiR") 4 | #' data(txp_example_model, package = "toxpiR") 5 | #' 6 | 7 | -------------------------------------------------------------------------------- /man-roxygen/roxgn-calcTxpModel.R: -------------------------------------------------------------------------------- 1 | #' @examples 2 | #' ## Calculate scores for single model; returns TxpResult object 3 | #' res <- txpCalculateScores(model = txp_example_model, 4 | #' input = txp_example_input, 5 | #' id.var = "name") 6 | #' 7 | 8 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | 16 | -------------------------------------------------------------------------------- /man-roxygen/roxgn-calcTxpModelList.R: -------------------------------------------------------------------------------- 1 | #' @examples 2 | #' ## Calculate scores for list of models; returns TxpResultList object 3 | #' txpCalculateScores(model = TxpModelList(m1 = txp_example_model, 4 | #' m2 = txp_example_model), 5 | #' input = txp_example_input, 6 | #' id.var = "name") 7 | #' resLst <- txpCalculateScores(model = list(m1 = txp_example_model, 8 | #' m2 = txp_example_model), 9 | #' input = txp_example_input, 10 | #' id.var = "name") 11 | #' 12 | 13 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # toxpiR 1.3.0 2 | 3 | * Added 'txpMissing' slot to TxpResult; this stores information regarding the 4 | amount of missing data in the dataset per slice 5 | * Added ggplot capabilities for plotting with several new aesthetics 6 | * Updated vignettes 7 | * Transferred maintainer to Jonathon F Fleming 8 | 9 | 10 | # toxpiR 1.2.0 11 | 12 | * Now require R>=4.0 due to reports of installation issues 13 | * Added 'txpValueNames' method for TxpModel 14 | * Added 'txpExportGui' function 15 | * Added 'TxpResultParam' object and 'txpResultParam' slot to TxpResult; this 16 | stores the parameters controlling the calculation of the scores, e.g. the 17 | rank ties method 18 | * Modified the log transformation functions within txpImportGui to match the 19 | negative value handling behavior in the GUI 20 | * Updated vignettes -------------------------------------------------------------------------------- /tests/testthat/guiFiles/gui_bad_input.csv: -------------------------------------------------------------------------------- 1 | ,,,,2,2,1,3,3,3,3,2 2 | ,,,,Slice1,Slice1,Slice2,Slice3,Slice3,Slice3,Slice3,Slice4 3 | ,,,,assay,pathway,exposure,assay,pathway,chemprop,exposure,pathway 4 | ,,,,NA,NA,NA,NA,NA,NA,NA,NA 5 | Row,Source,CASRN,Name,metric1,metric2,metric4,metric1,metric2,metric3,metric4,metric2 6 | 1,source1,11-111-1111,chem1,74,77,25,74,77,97,25,77 7 | 2,source2,22-222-2222,chem2,28,20,72,28,20,68,72,20 8 | 3,source3,33-333-3333,chem3,61,3,73,61,3,24,73,3 9 | 4,source4,44-444-4444,chem4,NA,40,20,NA,40,22,20,40 10 | 5,source5,55-555-5555,chem5,29,53,44,29,53,4,44,53 11 | 6,source6,66-666-6666,chem6,12,43,83,12,43,85,83,43 12 | 7,source7,77-777-7777,chem7,29,NA,NA,29,NA,38,NA,NA 13 | 8,source8,88-888-8888,chem8,58,66,70,58,66,NA,70,66 14 | 9,source9,99-999-9999,chem9,51,84,58,51,84,NA,58,84 15 | 10,source10,11-222-3333,chem10,60,40,32,60,40,38,32,40 -------------------------------------------------------------------------------- /man/txpImportGui.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/txpImportGui.R 3 | \name{txpImportGui} 4 | \alias{txpImportGui} 5 | \title{Import data file generated by ToxPi GUI} 6 | \usage{ 7 | txpImportGui(guiDataFile) 8 | } 9 | \arguments{ 10 | \item{guiDataFile}{Character scalar, the path to a 'data' export from the 11 | ToxPi GUI} 12 | } 13 | \value{ 14 | \code{list} with \verb{$model} containing \link{TxpModel} object; \verb{$input} 15 | containing \code{data.frame} with input data; \verb{$fills} containing a vector 16 | of fill colors. 17 | } 18 | \description{ 19 | Import data file generated by ToxPi GUI 20 | } 21 | \details{ 22 | This function takes the '_data.csv' files generated by the GUI. 23 | See \url{https://toxpi.org} for more information. 24 | 25 | Because of the way toxpiR implements transformation functions, there is not 26 | a way currently to use the GUI 'hitcount' function. 27 | } 28 | -------------------------------------------------------------------------------- /man/boxLegendGrob.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotting-boxLegendGrob.R 3 | \name{boxLegendGrob} 4 | \alias{boxLegendGrob} 5 | \title{Create a filled-box legend} 6 | \usage{ 7 | boxLegendGrob(labels, fills, name = NULL, vp = NULL, gp = NULL) 8 | } 9 | \arguments{ 10 | \item{labels}{Character, the legend labels} 11 | 12 | \item{fills}{Colors to fill the slices} 13 | 14 | \item{name, vp, gp}{Passed to \link[grid:grid.frame]{grid::frameGrob}} 15 | } 16 | \description{ 17 | Create a filled-box legend 18 | } 19 | \details{ 20 | Not yet exported. Need to break out the creation of viewports and grobs as 21 | done in the exported grobs. This will allow better grobEdit methods, which 22 | also needs to be created for the boxLegendGrob. 23 | Also need to do some input checks. 24 | 25 | Also, if \code{grid::legendGrob} gets updated to use the 'has.fill' option 26 | this function should be removed and \code{grid::legendGrob} can be used 27 | instead. 28 | } 29 | -------------------------------------------------------------------------------- /R/methods-NamedList.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## methods-NamedList 3 | ##----------------------------------------------------------------------------## 4 | 5 | ##----------------------------------------------------------------------------## 6 | ## validity 7 | 8 | #' @importFrom S4Vectors classNameForDisplay 9 | 10 | .NamedList.validity <- function(object) { 11 | msg <- NULL 12 | cname <- classNameForDisplay(object) 13 | if (length(object) > 0 && is.null(names(object))) { 14 | msg <- c(msg, sprintf("%s must have names.", cname)) 15 | } 16 | if (any(duplicated(names(object)))) { 17 | msg <- c(msg, sprintf("%s names must be unique.", cname)) 18 | } 19 | if (any(is.na(names(object)))) { 20 | msg <- c(msg, sprintf("%s names must not be .", cname)) 21 | } 22 | if (is.null(msg)) return(TRUE) 23 | msg 24 | } 25 | 26 | setValidity2("NamedList", .NamedList.validity) 27 | 28 | ##----------------------------------------------------------------------------## 29 | -------------------------------------------------------------------------------- /tests/testthat/test-TxpTransFunc.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## TxpTransFunc tests 3 | ##----------------------------------------------------------------------------## 4 | 5 | ##----------------------------------------------------------------------------## 6 | ## Initialization 7 | 8 | test_that("We can create TxpTransFunc objects", { 9 | fx <- function(x) x + 1 10 | expect_s4_class(tf <- TxpTransFunc(fx), "TxpTransFunc") 11 | expect_s4_class(as(fx, "TxpTransFunc"), "TxpTransFunc") 12 | expect_condition(body(tf) == "x + 1", regexp = NA) 13 | expect_equal(formalArgs(tf), "x") 14 | expect_equal(tf(1:10), 1:10 + 1) 15 | expect_error(TxpTransFunc(function(x) "hello")) 16 | expect_error(TxpTransFunc(function(x) x + "a")) 17 | expect_error(TxpTransFunc(1)) 18 | }) 19 | 20 | test_that("TxpTransFunc can handle primitives", { 21 | expect_warning(f1 <- TxpTransFunc(sqrt)) 22 | expect_equal(f1(1:10), sqrt(1:10)) 23 | expect_warning(f2 <- as(sqrt, "TxpTransFunc")) 24 | expect_equal(f2(1:10), sqrt(1:10)) 25 | }) 26 | -------------------------------------------------------------------------------- /tests/testthat/guiFiles/gui_output_data.csv: -------------------------------------------------------------------------------- 1 | "# Slice1!2!0xf3622dff!linear(x)","","","","x","x","","" 2 | "# Slice2!1!0xff7e4eff!linear(x)","","","","","","x","" 3 | "# Slice3!3!0xff9269ff!linear(x)","","","","x","x","x","x" 4 | "# Slice4!2!0xffa27fff!linear(x)","","","","","x","","" 5 | "","","","","assay","pathway","exposure","chemprop" 6 | "","","","","NA","NA","NA","NA" 7 | "row","SID","CASRN","Name","metric1","metric2","metric4","metric3" 8 | "1","source1","11-111-1111","chem1","74.0","77.0","25.0","97.0" 9 | "2","source2","22-222-2222","chem2","28.0","20.0","72.0","68.0" 10 | "3","source3","33-333-3333","chem3","61.0","3.0","73.0","24.0" 11 | "4","source4","44-444-4444","chem4","NaN","40.0","20.0","22.0" 12 | "5","source5","55-555-5555","chem5","29.0","53.0","44.0","4.0" 13 | "6","source6","66-666-6666","chem6","12.0","43.0","83.0","85.0" 14 | "7","source7","77-777-7777","chem7","29.0","NaN","NaN","38.0" 15 | "8","source8","88-888-8888","chem8","58.0","66.0","70.0","NaN" 16 | "9","source9","99-999-9999","chem9","51.0","84.0","58.0","NaN" 17 | "10","source10","11-222-3333","chem10","60.0","40.0","32.0","38.0" 18 | -------------------------------------------------------------------------------- /tests/testthat/guiFiles/gui_output_missingFuncs.csv: -------------------------------------------------------------------------------- 1 | "# Slice1!2!0xf3622dff!hitcall(x)","","","","x","x","","" 2 | "# Slice2!1!0xff7e4eff!function(x)","","","","","","x","" 3 | "# Slice3!3!0xff9269ff!f(x)","","","","x","x","x","x" 4 | "# Slice4!2!0xffa27fff!hello(x)","","","","","x","","" 5 | "","","","","assay","pathway","exposure","chemprop" 6 | "","","","","NA","NA","NA","NA" 7 | "row","SID","CASRN","Name","metric1","metric2","metric4","metric3" 8 | "1","source1","11-111-1111","chem1","74.0","77.0","25.0","97.0" 9 | "2","source2","22-222-2222","chem2","28.0","20.0","72.0","68.0" 10 | "3","source3","33-333-3333","chem3","61.0","3.0","73.0","24.0" 11 | "4","source4","44-444-4444","chem4","NaN","40.0","20.0","22.0" 12 | "5","source5","55-555-5555","chem5","29.0","53.0","44.0","4.0" 13 | "6","source6","66-666-6666","chem6","12.0","43.0","83.0","85.0" 14 | "7","source7","77-777-7777","chem7","29.0","NaN","NaN","38.0" 15 | "8","source8","88-888-8888","chem8","58.0","66.0","70.0","NaN" 16 | "9","source9","99-999-9999","chem9","51.0","84.0","58.0","NaN" 17 | "10","source10","11-222-3333","chem10","60.0","40.0","32.0","38.0" 18 | -------------------------------------------------------------------------------- /tests/testthat/guiFiles/gui_output_nonNumeric.csv: -------------------------------------------------------------------------------- 1 | "# Slice1!2!0xf3622dff!linear(x)","","","","x","x","","" 2 | "# Slice2!1!0xff7e4eff!linear(x)","","","","","","x","" 3 | "# Slice3!3!0xff9269ff!linear(x)","","","","x","x","x","x" 4 | "# Slice4!2!0xffa27fff!linear(x)","","","","","x","","" 5 | "","","","","assay","pathway","exposure","chemprop" 6 | "","","","","NA","NA","NA","NA" 7 | "row","SID","CASRN","Name","metric1","metric2","metric4","metric3" 8 | "1","source1","11-111-1111","chem1","74.0","77.0","25.0","97.0" 9 | "2","source2","22-222-2222","chem2","28.0","20.0","72.0","68.0" 10 | "3","source3","33-333-3333","chem3","61.0","3.0","hello","24.0" 11 | "4","source4","44-444-4444","chem4","NaN","40.0","20.0","22.0" 12 | "5","source5","55-555-5555","chem5","29.0","53.0","44.0","4.0" 13 | "6","source6","66-666-6666","chem6","12.0","43.0","83.0","85.0" 14 | "7","source7","77-777-7777","chem7","29.0","NaN","NaN","38.0" 15 | "8","source8","88-888-8888","chem8","58.0","66.0","70.0","NaN" 16 | "9","source9","99-999-9999","chem9","51.0","hello","58.0","NaN" 17 | "10","source10","11-222-3333","chem10","60.0","40.0","32.0","38.0" 18 | -------------------------------------------------------------------------------- /man/figures/logo-favicon.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 14 | 15 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /tests/testthat/test-txpImportGui.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## txpImportGui tests 3 | ##----------------------------------------------------------------------------## 4 | 5 | test_that("We can import GUI outputs", { 6 | expect_warning({ 7 | l <- txpImportGui(file.path("guiFiles", "gui_output_data.csv")) 8 | }) 9 | expect_type(l, "list") 10 | expect_s4_class(l$model, "TxpModel") 11 | expect_named(l$model, c("Slice1", "Slice2", "Slice3", "Slice4")) 12 | expect_s3_class(l$input, "data.frame") 13 | expect_named(l$input, 14 | c("row", "SID", "CASRN", "Name", "metric1", 15 | "metric2", "metric4", "metric3")) 16 | expect_error(txpImportGui(file.path("guiFiles", "gui_bad_input.csv"))) 17 | expect_error(txpImportGui(file.path("guiFiles", 18 | "gui_output_missingFuncs.csv")), 19 | "hitcall\\(x\\), function\\(x\\), f\\(x\\), hello\\(x\\)") 20 | expect_warning(expect_error({ 21 | txpImportGui(file.path("guiFiles", "gui_output_nonNumeric.csv")) 22 | }, "metric1, metric3")) 23 | # expect_silent({ 24 | # dl <- txpImportGui(file.path("guiFiles", "gui_distributions.csv")) 25 | # expect_warning(txpCalculateScores(dl$model, dl$input), "NaNs produced") 26 | # }) 27 | }) 28 | -------------------------------------------------------------------------------- /man/pieGrob.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotting-pieGrob.R 3 | \name{pieGrob} 4 | \alias{pieGrob} 5 | \alias{grid.pieGrob} 6 | \title{Create a pie grob} 7 | \usage{ 8 | pieGrob(rads, fills = NULL, wts = NULL, name = NULL, vp = NULL, gp = NULL) 9 | 10 | grid.pieGrob(rads, fills = NULL, wts = NULL, name = NULL, vp = NULL, gp = NULL) 11 | } 12 | \arguments{ 13 | \item{rads}{Numeric, radius values for each slice from 0 to 1} 14 | 15 | \item{fills}{Colors to fill the slices} 16 | 17 | \item{wts}{Numeric, the relative portion of each slice} 18 | 19 | \item{name, vp, gp}{Passed to \link[grid:grid.grob]{grid::gTree}} 20 | } 21 | \value{ 22 | \code{pieGrob} \link[grid:grid.grob]{grid::grob} object 23 | } 24 | \description{ 25 | Create a pie grob 26 | } 27 | \details{ 28 | The default coloring can be set with \code{options("txp.fills")}. 29 | } 30 | \examples{ 31 | library(grid) 32 | 33 | s <- seq(0.2, 1, by = 0.1) 34 | grid.newpage() 35 | grid.pieGrob(rads = s) 36 | grid.newpage() 37 | grid.pieGrob(rads = s, wts = s) 38 | 39 | curr_txp_fills <- options()$txp.fills 40 | options(txp.fills = 1:8) 41 | grid.newpage() 42 | grid.pieGrob(rads = s) 43 | options(txp.fills = curr_txp_fills) 44 | 45 | ## Can edit 46 | grid.newpage() 47 | grid.pieGrob(rads = s, name = "myPie") 48 | grid.ls() ## show the grid elements 49 | grid.edit("myPie", fills = 1:9, wts = 9:1) 50 | 51 | } 52 | -------------------------------------------------------------------------------- /man/txpGenerics.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/allGenerics.R 3 | \name{txpGenerics} 4 | \alias{txpGenerics} 5 | \alias{txpValueNames} 6 | \alias{txpValueNames<-} 7 | \alias{txpTransFuncs} 8 | \alias{txpTransFuncs<-} 9 | \alias{txpSlices} 10 | \alias{txpSlices<-} 11 | \alias{txpWeights} 12 | \alias{txpWeights<-} 13 | \alias{txpScores} 14 | \alias{txpSliceScores} 15 | \alias{txpModel} 16 | \alias{txpIDs} 17 | \alias{txpIDs<-} 18 | \alias{txpRanks} 19 | \alias{txpMissing} 20 | \alias{txpResultParam} 21 | \title{toxpiR package generics} 22 | \usage{ 23 | txpValueNames(x, ...) 24 | 25 | txpValueNames(x, ...) <- value 26 | 27 | txpTransFuncs(x, ...) 28 | 29 | txpTransFuncs(x, ...) <- value 30 | 31 | txpSlices(x, ...) 32 | 33 | txpSlices(x, ...) <- value 34 | 35 | txpWeights(x, ...) 36 | 37 | txpWeights(x, ...) <- value 38 | 39 | txpScores(x, ...) 40 | 41 | txpSliceScores(x, ...) 42 | 43 | txpModel(x, ...) 44 | 45 | txpIDs(x, ...) 46 | 47 | txpIDs(x, ...) <- value 48 | 49 | txpRanks(x, ...) 50 | 51 | txpMissing(x, ...) 52 | 53 | txpResultParam(x, ...) 54 | } 55 | \arguments{ 56 | \item{x}{toxpiR S4 object} 57 | 58 | \item{...}{Included for extendability; not currently used} 59 | 60 | \item{value}{Replacement value} 61 | } 62 | \value{ 63 | See specific methods for details. 64 | } 65 | \description{ 66 | toxpiR package generics; see class man pages for associated 67 | methods 68 | } 69 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown.yaml 13 | 14 | permissions: read-all 15 | 16 | jobs: 17 | pkgdown: 18 | runs-on: ubuntu-latest 19 | # Only restrict concurrency for non-PR jobs 20 | concurrency: 21 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 22 | env: 23 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 24 | permissions: 25 | contents: write 26 | steps: 27 | - uses: actions/checkout@v4 28 | 29 | - uses: r-lib/actions/setup-pandoc@v2 30 | 31 | - uses: r-lib/actions/setup-r@v2 32 | with: 33 | use-public-rspm: true 34 | 35 | - uses: r-lib/actions/setup-r-dependencies@v2 36 | with: 37 | extra-packages: any::pkgdown, local::. 38 | needs: website 39 | 40 | - name: Build site 41 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 42 | shell: Rscript {0} 43 | 44 | - name: Deploy to GitHub pages 🚀 45 | if: github.event_name != 'pull_request' 46 | uses: JamesIves/github-pages-deploy-action@v4.5.0 47 | with: 48 | clean: false 49 | branch: gh-pages 50 | folder: docs 51 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: R-CMD-check.yaml 10 | 11 | permissions: read-all 12 | 13 | jobs: 14 | R-CMD-check: 15 | runs-on: ${{ matrix.config.os }} 16 | 17 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 18 | 19 | strategy: 20 | fail-fast: false 21 | matrix: 22 | config: 23 | - {os: macos-latest, r: 'release'} 24 | - {os: windows-latest, r: 'release'} 25 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 26 | - {os: ubuntu-latest, r: 'release'} 27 | - {os: ubuntu-latest, r: 'oldrel-1'} 28 | 29 | env: 30 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 31 | R_KEEP_PKG_SOURCE: yes 32 | 33 | steps: 34 | - uses: actions/checkout@v4 35 | 36 | - uses: r-lib/actions/setup-pandoc@v2 37 | 38 | - uses: r-lib/actions/setup-r@v2 39 | with: 40 | r-version: ${{ matrix.config.r }} 41 | http-user-agent: ${{ matrix.config.http-user-agent }} 42 | use-public-rspm: true 43 | 44 | - uses: r-lib/actions/setup-r-dependencies@v2 45 | with: 46 | extra-packages: Rcpp,rcmdcheck 47 | needs: check 48 | 49 | - uses: r-lib/actions/check-r-package@v2 50 | with: 51 | upload-snapshots: true 52 | build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' 53 | -------------------------------------------------------------------------------- /man/TxpResultParam-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/allClasses.R, R/methods-TxpResultParam.R 3 | \docType{class} 4 | \name{TxpResultParam-class} 5 | \alias{TxpResultParam-class} 6 | \alias{TxpResultParam} 7 | \title{ToxPi Result Parameters} 8 | \arguments{ 9 | \item{rank.ties.method}{Passed to \code{rank.ties.method} slot} 10 | 11 | \item{negative.value.handling}{Passed to \code{negative.value.handling} slot} 12 | } 13 | \description{ 14 | S4 class to store ToxPi result calculation parameters 15 | } 16 | \details{ 17 | If more than one value is passed to \code{TxoResultParam} scalar options, e.g. 18 | \code{rank.ties.method}, only the first value is kept. 19 | 20 | The \code{rank.ties.method} slot is passed to \link[base:rank]{base::rank} for calculating the 21 | ranks of observations, with the highest-scoring observation having the rank 22 | of 1. 23 | 24 | \code{negative.value.handling} indicates how to handle negative values in the 25 | inputs. The ToxPi algorithm originally intended to accept non-negative 26 | potency values; the GUI, therefore, treats negative values in the input as 27 | missing. By default, \link{txpCalculateScores} keeps negative values 28 | (\code{negative.value.handling = "keep"}). To replicate the GUI behavior, users 29 | can set \code{negative.value.handling = "missing"}. 30 | } 31 | \section{Slots}{ 32 | 33 | \describe{ 34 | \item{\code{rank.ties.method}}{Character scalar, method used to calculate score 35 | ranks passed to \link[base:rank]{base::rank}} 36 | 37 | \item{\code{negative.value.handling}}{Character scalar, how negative values are 38 | handled, see details} 39 | }} 40 | 41 | \seealso{ 42 | \link{txpCalculateScores}, \link{TxpResult} 43 | } 44 | -------------------------------------------------------------------------------- /man/TxpTransFunc-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/allClasses.R, R/methods-TxpTransFunc.R 3 | \docType{class} 4 | \name{TxpTransFunc-class} 5 | \alias{TxpTransFunc-class} 6 | \alias{TxpTransFunc} 7 | \title{Numeric transformation function} 8 | \usage{ 9 | TxpTransFunc(x) 10 | } 11 | \arguments{ 12 | \item{x}{function, see details} 13 | } 14 | \description{ 15 | S4 class to store numeric transformation functions 16 | } 17 | \details{ 18 | \code{TxpTransFunc} inherits from a standard R function, but specifies a 19 | single input and a numeric output of the same length. 20 | 21 | Functions can be passed directly to \code{TxpTransFuncList} list and the 22 | functions will be coerced to \code{TxpTransFunc}. 23 | 24 | We have an imperfect system for dealing with primitive functions (e.g., 25 | \link[base:MathFun]{base::sqrt}). 26 | To coerce primitives to TxpTransFunc's, we wrap them in another function 27 | cal; wrapping the primitives obscures the original function and requires 28 | the user to explore the function environment to understand the primitive 29 | called. 30 | We recommend wrapping primitives in separate functions to make the intent 31 | clear, .e.g., \code{mysqrt <- function(x) sqrt(x)}. 32 | } 33 | \examples{ 34 | f1 <- function(x) "hello" 35 | f2 <- function(x) 3 36 | f3 <- function(x) x + 5 37 | \dontrun{ 38 | t1 <- TxpTransFunc(x = f1) ## Produces error 39 | t2 <- TxpTransFunc(x = f2) ## Produces error 40 | } 41 | t3 <- TxpTransFunc(x = f3) 42 | 43 | ## TxpTransFunc objects act as any other function 44 | body(t3) 45 | formals(t3) 46 | t3(1:10) 47 | 48 | ## Coercion from functions 49 | \dontrun{ 50 | TxpTransFuncList(f1, f2, f3) ## Produces error because f1, f3 not valid 51 | } 52 | } 53 | -------------------------------------------------------------------------------- /man/figures/logo-banner.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | toxpiR 30 | 31 | reif-lab.org 32 | 33 | 34 | 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /man/txpExportGui.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/txpExportGui.R 3 | \name{txpExportGui} 4 | \alias{txpExportGui} 5 | \title{Export comma-separated file intended for ToxPi GUI} 6 | \usage{ 7 | txpExportGui( 8 | fileName = "txpModel.csv", 9 | input, 10 | model, 11 | id.var = NULL, 12 | fills = NULL 13 | ) 14 | } 15 | \arguments{ 16 | \item{fileName}{Character scalar, the path to the output file} 17 | 18 | \item{input}{data.frame object containing the model input data} 19 | 20 | \item{model}{\link{TxpModel} object or \link{TxpModelList} object} 21 | 22 | \item{id.var}{Character scalar, column in 'input' to store in} 23 | 24 | \item{fills}{Colors to fill the slices} 25 | } 26 | \description{ 27 | Export comma-separated file intended for ToxPi GUI 28 | } 29 | \details{ 30 | The GUI differs in two meaninful ways for exporting \code{toxpiR} models: (1) the 31 | GUI only allows for integer weights; (2) the GUI applies transformation 32 | functions differently. 33 | 34 | \code{txpExporGui} will not work for models with non-integer weights. 35 | 36 | The GUI only applies a single transformation function to every input within 37 | a slice, and only functions from a pre-determined list; \code{toxpiR} allows 38 | users to apply any valid function individually to each input, then a second 39 | transformation function on the summed slice values. Because of this 40 | complexity, any exported models with slice-level transformation functions 41 | will not export at the input level. In other words, the export will have only 42 | the final slice scores. Otherwise, all input-level transformations will be 43 | performed, the and the export will contain transformed input-level data with 44 | the \code{linear(x)} GUI transformation. 45 | } 46 | -------------------------------------------------------------------------------- /man/toxpiR-datasets.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/toxpiR-package.R 3 | \name{toxpiR-datasets} 4 | \alias{toxpiR-datasets} 5 | \alias{txp_example_input} 6 | \alias{txp_example_model} 7 | \title{toxpiR data objects} 8 | \source{ 9 | \url{https://github.com/ToxPi/ToxPi-example-files} 10 | } 11 | \usage{ 12 | data(txp_example_input, package = "toxpiR") 13 | 14 | data(txp_example_model, package = "toxpiR") 15 | } 16 | \description{ 17 | Objects included in the toxpiR package, loaded with 18 | \link[utils:data]{utils::data} 19 | } 20 | \section{txp_example_input}{ 21 | 22 | 23 | Small example input data to be used with \link{txpCalculateScores} in creating 24 | \link{TxpResult} objects. A \link[base:data.frame]{base::data.frame} with 10 rows and 9 variables 25 | \describe{ 26 | \item{name}{Observation names} 27 | \item{metric#}{Input data for ToxPi models} 28 | } 29 | } 30 | 31 | \section{txp_example_model}{ 32 | 33 | 34 | Example \link{TxpModel} object intended for \code{txp_example_data}; model with 4 35 | slices. 36 | } 37 | 38 | \examples{ 39 | data(txp_example_input, package = "toxpiR") 40 | data(txp_example_model, package = "toxpiR") 41 | txp_example_input 42 | txp_example_model 43 | 44 | ## Code to create txp_example_model 45 | tf1 <- TxpTransFuncList(linear = function(x) x) 46 | sl <- TxpSliceList(s1 = TxpSlice(sprintf("metric\%d", 1:2)), 47 | s2 = TxpSlice("metric3"), 48 | s3 = TxpSlice(sprintf("metric\%d", 4:7), 49 | tf1[rep("linear", 4)]), 50 | s4 = TxpSlice("metric8", tf1)) 51 | tf2 <- TxpTransFuncList(NULL, linear = function(x) x, NULL, NULL) 52 | TxpModel(txpSlices = sl, txpWeights = c(2, 1, 3, 2), txpTransFuncs = tf2) 53 | 54 | } 55 | -------------------------------------------------------------------------------- /man/toxpiR-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/toxpiR-package.R 3 | \docType{package} 4 | \name{toxpiR-package} 5 | \alias{toxpiR} 6 | \alias{toxpiR-package} 7 | \title{toxpiR: Create ToxPi Prioritization Models} 8 | \description{ 9 | Enables users to build 'ToxPi' prioritization models and provides functionality within the grid framework for plotting ToxPi graphs. 'toxpiR' allows for more customization than the 'ToxPi GUI' (\url{https://toxpi.org}) and integration into existing workflows for greater ease-of-use, reproducibility, and transparency. toxpiR package behaves nearly identically to the GUI; the package documentation includes notes about all differences. The vignettes download example files from \url{https://github.com/ToxPi/ToxPi-example-files}. 10 | } 11 | \seealso{ 12 | Useful links: 13 | \itemize{ 14 | \item \url{https://github.com/ToxPi/toxpiR} 15 | \item \url{https://toxpi.github.io/toxpiR/} 16 | \item Report bugs at \url{https://github.com/ToxPi/toxpiR/issues} 17 | } 18 | 19 | } 20 | \author{ 21 | \strong{Maintainer}: Jonathon F Fleming \email{jffleming0129@gmail.com} (\href{https://orcid.org/0000-0003-2447-3139}{ORCID}) 22 | 23 | Authors: 24 | \itemize{ 25 | \item Dayne L Filer \email{dayne.filer@gmail.com} (\href{https://orcid.org/0000-0002-3443-5315}{ORCID}) [funder] 26 | \item Dillon T Lloyd 27 | \item Preethi Thunga (\href{https://orcid.org/0000-0001-5447-0129}{ORCID}) 28 | \item Skylar W Marvel 29 | \item David M Reif \email{reif.david@gmail.com} (\href{https://orcid.org/0000-0001-7815-6767}{ORCID}) [funder] 30 | } 31 | 32 | Other contributors: 33 | \itemize{ 34 | \item Alison A Motsinger-Reif (\href{https://orcid.org/0000-0003-1346-2493}{ORCID}) [funder] 35 | } 36 | 37 | } 38 | \keyword{internal} 39 | -------------------------------------------------------------------------------- /man/TxpResultList-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/allClasses.R, R/methods-TxpResultList.R 3 | \docType{class} 4 | \name{TxpResultList-class} 5 | \alias{TxpResultList-class} 6 | \alias{TxpResultList} 7 | \alias{duplicated,TxpResultList-method} 8 | \alias{as.TxpResultList} 9 | \title{List of TxpResult objects} 10 | \usage{ 11 | TxpResultList(...) 12 | 13 | \S4method{duplicated}{TxpResultList}(x) 14 | 15 | as.TxpResultList(x) 16 | } 17 | \arguments{ 18 | \item{...}{\link{TxpResult} object to create \code{TxpResultList} object} 19 | 20 | \item{x}{\code{TxpResultList} object} 21 | } 22 | \description{ 23 | Extension of \link[S4Vectors:SimpleList-class]{S4Vectors::SimpleList} that holds only \link{TxpResult} 24 | objects. 25 | } 26 | \examples{ 27 | ## Load example dataset & model; see ?TxpModel for building model objects 28 | data(txp_example_input, package = "toxpiR") 29 | data(txp_example_model, package = "toxpiR") 30 | 31 | ## Calculate scores for list of models; returns TxpResultList object 32 | txpCalculateScores(model = TxpModelList(m1 = txp_example_model, 33 | m2 = txp_example_model), 34 | input = txp_example_input, 35 | id.var = "name") 36 | resLst <- txpCalculateScores(model = list(m1 = txp_example_model, 37 | m2 = txp_example_model), 38 | input = txp_example_input, 39 | id.var = "name") 40 | 41 | ## duplicated 42 | duplicated(resLst) 43 | 44 | ## Coercion 45 | as(list(resLst[[1]], resLst[[2]]), "TxpResultList") 46 | as.TxpResultList(list(res1 = resLst[[1]], res2 = resLst[[2]])) 47 | 48 | as(resLst[[1]], "TxpResultList") 49 | as.TxpResultList(resLst[[1]]) 50 | } 51 | \seealso{ 52 | \link{TxpResult}, \link{txpCalculateScores} 53 | } 54 | -------------------------------------------------------------------------------- /man/TxpTransFuncList-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/allClasses.R, R/methods-TxpTransFuncList.R 3 | \docType{class} 4 | \name{TxpTransFuncList-class} 5 | \alias{TxpTransFuncList-class} 6 | \alias{TxpTransFuncList} 7 | \alias{as.TxpTransFuncList} 8 | \title{List of TxpTransFunc objects} 9 | \usage{ 10 | TxpTransFuncList(...) 11 | 12 | as.TxpTransFuncList(x) 13 | } 14 | \arguments{ 15 | \item{...}{\link{TxpTransFunc} object or function to create \code{TxpTransFuncList} 16 | object} 17 | 18 | \item{x}{\code{list}, \code{function}, or \link{TxpTransFunc} object to coerce to 19 | \code{TxpTransFuncList}} 20 | } 21 | \description{ 22 | Extension of \link[S4Vectors:SimpleList-class]{S4Vectors::SimpleList} that holds only \code{NULL} or 23 | \link{TxpTransFunc} objects. 24 | } 25 | \details{ 26 | When \code{...} includes function objects, \code{TxpTransFuncList} will attempt to 27 | coerce them to \link{TxpTransFunc} and return an error if any of the elements 28 | cannot be coerced to \link{TxpTransFunc}. 29 | } 30 | \examples{ 31 | ## Create TxpTransFunc objects 32 | tf1 <- TxpTransFunc(function(x) x) 33 | tf2 <- TxpTransFunc(function(x) sqrt(x)) 34 | 35 | ## Create TxpTransFuncList 36 | tfl <- TxpTransFuncList(linear = tf1, sqrt = tf2, cube = function(x) x^3) 37 | tfl[[3]](3) == 27 38 | tfl[["sqrt"]](4) == 2 39 | 40 | ## Concatenate 41 | c(tfl, tfl) 42 | 43 | ## names 44 | names(c(tfl, tfl)) 45 | 46 | # note: names are printed as '' when missing; NULL is printed when list item 47 | # is NULL 48 | names(TxpTransFuncList(function(x) x, NULL)) 49 | TxpTransFuncList(function(x) x, NULL) 50 | 51 | ## coercion 52 | as(function(x) x, "TxpTransFuncList") 53 | as.TxpTransFuncList(function(x) x) 54 | 55 | as(TxpTransFunc(function(x) x), "TxpTransFuncList") 56 | as.TxpTransFuncList(TxpTransFunc(function(x) x)) 57 | 58 | as(list(function(x) x, sqrt = function(x) sqrt(x)), "TxpTransFuncList") 59 | as.TxpTransFuncList(list(function(x) x, sqrt = function(x) sqrt(x))) 60 | } 61 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: test-coverage.yaml 10 | 11 | permissions: read-all 12 | 13 | jobs: 14 | test-coverage: 15 | runs-on: ubuntu-latest 16 | env: 17 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 18 | 19 | steps: 20 | - uses: actions/checkout@v4 21 | 22 | - uses: r-lib/actions/setup-r@v2 23 | with: 24 | use-public-rspm: true 25 | 26 | - uses: r-lib/actions/setup-r-dependencies@v2 27 | with: 28 | extra-packages: any::covr, any::xml2 29 | needs: coverage 30 | 31 | - name: Test coverage 32 | run: | 33 | cov <- covr::package_coverage( 34 | quiet = FALSE, 35 | clean = FALSE, 36 | install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") 37 | ) 38 | covr::to_cobertura(cov) 39 | shell: Rscript {0} 40 | 41 | - uses: codecov/codecov-action@v4 42 | with: 43 | fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }} 44 | file: ./cobertura.xml 45 | plugin: noop 46 | disable_search: true 47 | token: ${{ secrets.CODECOV_TOKEN }} 48 | 49 | - name: Show testthat output 50 | if: always() 51 | run: | 52 | ## -------------------------------------------------------------------- 53 | find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true 54 | shell: bash 55 | 56 | - name: Upload test results 57 | if: failure() 58 | uses: actions/upload-artifact@v4 59 | with: 60 | name: coverage-test-failures 61 | path: ${{ runner.temp }}/package -------------------------------------------------------------------------------- /man/TxpModelList-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/allClasses.R, R/methods-TxpModelList.R 3 | \docType{class} 4 | \name{TxpModelList-class} 5 | \alias{TxpModelList-class} 6 | \alias{TxpModelList} 7 | \alias{duplicated,TxpModelList-method} 8 | \alias{as.TxpModelList} 9 | \title{List of TxpModel objects} 10 | \usage{ 11 | TxpModelList(...) 12 | 13 | \S4method{duplicated}{TxpModelList}(x) 14 | 15 | as.TxpModelList(x) 16 | } 17 | \arguments{ 18 | \item{...}{\link{TxpModel} object to create \code{TxpModelList} object} 19 | 20 | \item{x}{\code{TxpModelList} object} 21 | } 22 | \description{ 23 | Extension of \link[S4Vectors:SimpleList-class]{S4Vectors::SimpleList} that holds only \link{TxpModel} 24 | objects. 25 | } 26 | \section{Functions}{ 27 | \itemize{ 28 | \item \code{duplicated(TxpModelList)}: Returns logical vector of \code{length(x)}, where 29 | \code{TRUE} indicates a duplicate model in the list; see \link[base:duplicated]{base::duplicated} 30 | 31 | \item \code{as.TxpModelList()}: Coerce list or \link{TxpModel} objects to 32 | TxpModelList 33 | 34 | }} 35 | \examples{ 36 | ## Create some TxpModel objects; see ?TxpModel for more details 37 | s1 <- list(S1 = TxpSlice("inpt1"), S2 = TxpSlice("inpt2")) 38 | tf <- list(NULL, sqrt = function(x) sqrt(x)) 39 | m1 <- TxpModel(txpSlices = s1, txpWeights = 2:1, txpTransFuncs = tf) 40 | m2 <- m1 41 | txpSlices(m2) <- list(S3 = TxpSlice("inpt3"), S4 = TxpSlice("inpt4")) 42 | m3 <- merge(m1, m2) 43 | 44 | ## Build a TxpModelList object 45 | TxpModelList(m1 = m1, m2 = m2, m3 = m3) 46 | 47 | ## Note: names are printed as '' when all are NULL 48 | TxpModelList(m1, m2, m3) 49 | names(TxpModelList(m1, m2, m3)) 50 | 51 | ## Test for duplicates 52 | duplicated(TxpModelList(m1 = m1, m2 = m2, m3 = m3)) 53 | duplicated(TxpModelList(m1 = m1, m2 = m1, m3 = m3)) 54 | 55 | ## Coerce lists/TxpModel objects to TxpModelList 56 | as(list(m1 = m1, m2 = m2, m3 = m3), "TxpModelList") 57 | as.TxpModelList(list(m1 = m1, m2 = m2, m3 = m3)) 58 | 59 | as(m1, "TxpModelList") 60 | as.TxpModelList(m1) 61 | } 62 | -------------------------------------------------------------------------------- /R/plotting-boxLegendGrob.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## boxLegendGrob 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name boxLegendGrob 6 | #' @title Create a filled-box legend 7 | #' @description Create a filled-box legend 8 | #' @param labels Character, the legend labels 9 | #' @param fills Colors to fill the slices 10 | #' @param name,vp,gp Passed to [grid::frameGrob] 11 | #' 12 | #' @details 13 | #' Not yet exported. Need to break out the creation of viewports and grobs as 14 | #' done in the exported grobs. This will allow better grobEdit methods, which 15 | #' also needs to be created for the boxLegendGrob. 16 | #' Also need to do some input checks. 17 | #' 18 | #' Also, if \code{grid::legendGrob} gets updated to use the 'has.fill' option 19 | #' this function should be removed and \code{grid::legendGrob} can be used 20 | #' instead. 21 | #' 22 | #' @import grid 23 | 24 | boxLegendGrob <- function(labels, fills, name = NULL, vp = NULL, gp = NULL) { 25 | 26 | wids <- c(unit(1.5, "char"), unit(max(nchar(labels)), "char")) 27 | hgts <- unit(rep_len(1.5, length(labels)), "char") 28 | fg <- frameGrob(layout = grid.layout(ncol = 2, 29 | nrow = length(labels), 30 | widths = wids, 31 | heights = hgts), 32 | vp = vp, 33 | name = name, 34 | gp = gp) 35 | for (i in seq_along(labels)) { 36 | fg <- placeGrob(frame = fg, 37 | grob = textGrob(label = labels[i]), 38 | col = 2, 39 | row = i) 40 | fg <- placeGrob(frame = fg, 41 | grob = rectGrob(width = unit(1, "char"), 42 | height = unit(1, "char"), 43 | gp = gpar(fill = fills[i], col = NA)), 44 | col = 1, 45 | row = i) 46 | } 47 | 48 | fg 49 | 50 | } 51 | 52 | ##----------------------------------------------------------------------------## 53 | 54 | -------------------------------------------------------------------------------- /R/toxpiR-package.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | "_PACKAGE" 3 | 4 | ## usethis namespace: start 5 | ## usethis namespace: end 6 | NULL 7 | 8 | # TXP_FILLS = c("dodgerblue", 9 | # "bisque", 10 | # "darkolivegreen3", 11 | # "darkorchid3", 12 | # "mistyrose2", 13 | # "darkgoldenrod1") 14 | TXP_FILLS = c( 15 | "#f3622d", 16 | "#fba71b", 17 | "#57b757", 18 | "#41a9c9", 19 | "#4258c9", 20 | "#9a42c8", 21 | "#c84164", 22 | "#888888" 23 | ) 24 | 25 | #' @name toxpiR-datasets 26 | #' @title toxpiR data objects 27 | #' @description Objects included in the toxpiR package, loaded with 28 | #' [utils::data] 29 | #' @aliases txp_example_input txp_example_model 30 | #' 31 | #' @usage data(txp_example_input, package = "toxpiR") 32 | #' @usage data(txp_example_model, package = "toxpiR") 33 | #' 34 | #' @section txp_example_input: 35 | #' 36 | #' Small example input data to be used with [txpCalculateScores] in creating 37 | #' [TxpResult] objects. A [base::data.frame] with 10 rows and 9 variables 38 | #' \describe{ 39 | #' \item{name}{Observation names} 40 | #' \item{metric#}{Input data for ToxPi models} 41 | #' } 42 | #' 43 | #' @source 44 | #' 45 | #' @section txp_example_model: 46 | #' 47 | #' Example [TxpModel] object intended for `txp_example_data`; model with 4 48 | #' slices. 49 | #' 50 | #' @examples 51 | #' data(txp_example_input, package = "toxpiR") 52 | #' data(txp_example_model, package = "toxpiR") 53 | #' txp_example_input 54 | #' txp_example_model 55 | #' 56 | #' ## Code to create txp_example_model 57 | #' tf1 <- TxpTransFuncList(linear = function(x) x) 58 | #' sl <- TxpSliceList(s1 = TxpSlice(sprintf("metric%d", 1:2)), 59 | #' s2 = TxpSlice("metric3"), 60 | #' s3 = TxpSlice(sprintf("metric%d", 4:7), 61 | #' tf1[rep("linear", 4)]), 62 | #' s4 = TxpSlice("metric8", tf1)) 63 | #' tf2 <- TxpTransFuncList(NULL, linear = function(x) x, NULL, NULL) 64 | #' TxpModel(txpSlices = sl, txpWeights = c(2, 1, 3, 2), txpTransFuncs = tf2) 65 | #' 66 | #' @importFrom utils data 67 | 68 | NULL 69 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # toxpiR 2 | 3 | 4 | [![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active) 5 | [![R-CMD-check](https://github.com/ToxPi/toxpiR/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/ToxPi/toxpiR/actions/workflows/R-CMD-check.yaml) 6 | [![cran-version](https://www.r-pkg.org/badges/version-last-release/toxpiR?color=blue)](https://cran.r-project.org/web/packages/toxpiR/index.html) 7 | [![downloads](https://cranlogs.r-pkg.org/badges/grand-total/toxpiR)](https://cranlogs.r-pkg.org/badges/grand-total/toxpiR) 8 | [![codecov](https://codecov.io/gh/ToxPi/toxpiR/branch/main/graph/badge.svg?token=7yocvT0KzZ)](https://codecov.io/gh/ToxPi/toxpiR) 9 | 10 | 11 | 12 | R package for the Toxicological Priority Index (ToxPi) prioritization algorithm. 13 | Package developed and maintained by the [Reif Lab](http://reif-lab.org) (Note that [David Reif has moved to NIH)](https://www.niehs.nih.gov/research/atniehs/labs/ptb/staff/reif). 14 | 15 | ### Installation 16 | 17 | Current stable release (CRAN): 18 | 19 | ```r 20 | install.packages("toxpiR") 21 | ``` 22 | 23 | Current stable release (Build from GitHub): 24 | 25 | ```r 26 | remotes::install_github("ToxPi/toxpiR", 27 | dependencies = TRUE) 28 | 29 | Note: Users may need to ensure "remotes" package and packages 30 | requiring "BiocManager" are installed before building package. 31 | 32 | if (!require(remotes)) install.packages("remotes") 33 | 34 | if (!require(BiocManager, quietly = TRUE)) { 35 | install.packages("BiocManager") 36 | } 37 | BiocManager::install(c("S4Vectors","BiocGenerics")) 38 | 39 | ``` 40 | 41 | Current stable release (Build from GitHub with vignettes): 42 | 43 | ```r 44 | remotes::install_github("ToxPi/toxpiR", 45 | dependencies = TRUE, 46 | build_vignettes = TRUE) 47 | 48 | Note: Building packages with vignettes requires the package 49 | "pandoc" to be installed. 50 | ``` 51 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: toxpiR 2 | Type: Package 3 | Title: Create ToxPi Prioritization Models 4 | Version: 1.3.1 5 | Author: Jonathon F Fleming [aut, cre] 6 | Maintainer: Jonathon F Fleming 7 | Authors@R: 8 | c(person("Jonathon F", "Fleming", 9 | role = c("aut","cre"), 10 | email = "jffleming0129@gmail.com", 11 | comment = c(ORCID = "0000-0003-2447-3139")), 12 | person("Dayne L", "Filer", 13 | role = c("aut", "fnd"), 14 | email = "dayne.filer@gmail.com", 15 | comment = c(ORCID = "0000-0002-3443-5315")), 16 | person("Dillon T", "Lloyd", 17 | role = "aut"), 18 | person("Preethi", "Thunga", 19 | role = "aut", 20 | comment = c(ORCID = "0000-0001-5447-0129")), 21 | person("Skylar W", "Marvel", 22 | role = "aut"), 23 | person("Alison A", "Motsinger-Reif", 24 | role = c("fnd"), 25 | comment = c(ORCID = "0000-0003-1346-2493")), 26 | person("David M", "Reif", 27 | role = c("aut", "fnd"), 28 | email = "reif.david@gmail.com", 29 | comment = c(ORCID = "0000-0001-7815-6767"))) 30 | Description: 31 | Enables users to build 'ToxPi' prioritization models and provides 32 | functionality within the grid framework for plotting ToxPi graphs. 33 | 'toxpiR' allows for more customization than the 'ToxPi GUI' 34 | () and integration into existing workflows for greater 35 | ease-of-use, reproducibility, and transparency. 36 | toxpiR package behaves nearly identically to the GUI; the package 37 | documentation includes notes about all differences. 38 | The vignettes download example files from 39 | . 40 | Imports: 41 | grDevices, 42 | methods, 43 | S4Vectors, 44 | grid, 45 | rlang, 46 | stats, 47 | BiocGenerics, 48 | tidyr, 49 | utils, 50 | ggplot2 51 | Encoding: UTF-8 52 | LazyData: true 53 | RoxygenNote: 7.3.3 54 | Roxygen: list(markdown = TRUE) 55 | Depends: 56 | R (>= 4.0) 57 | Suggests: 58 | rmarkdown, 59 | knitr, 60 | testthat (>= 3.0.0), 61 | covr, 62 | DBI 63 | Config/testthat/edition: 3 64 | Config/testthat/parallel: true 65 | VignetteBuilder: knitr 66 | License: GPL (>= 3) 67 | URL: https://github.com/ToxPi/toxpiR, 68 | https://toxpi.github.io/toxpiR/ 69 | BugReports: https://github.com/ToxPi/toxpiR/issues 70 | -------------------------------------------------------------------------------- /man/pieGridGrob.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/plotting-pieGridGrob.R 3 | \name{pieGridGrob} 4 | \alias{pieGridGrob} 5 | \alias{grid.pieGridGrob} 6 | \title{Make grid of pieGrobs} 7 | \usage{ 8 | pieGridGrob( 9 | radMat, 10 | wts = NULL, 11 | fills = NULL, 12 | labels = NULL, 13 | showRadSum = FALSE, 14 | ncol = NULL, 15 | nrow = NULL, 16 | byrow = TRUE, 17 | name = NULL, 18 | gp = NULL, 19 | vp = NULL 20 | ) 21 | 22 | grid.pieGridGrob( 23 | radMat, 24 | wts = NULL, 25 | fills = NULL, 26 | labels = NULL, 27 | showRadSum = FALSE, 28 | ncol = NULL, 29 | nrow = NULL, 30 | byrow = TRUE, 31 | name = NULL, 32 | gp = NULL, 33 | vp = NULL 34 | ) 35 | } 36 | \arguments{ 37 | \item{radMat}{\verb{matrix()}, observations by slice radii} 38 | 39 | \item{wts}{\verb{vector()}, relative weights of each slice} 40 | 41 | \item{fills}{Vector of colors to fill slices} 42 | 43 | \item{labels}{\verb{vector()}, (optional) label for each observation} 44 | 45 | \item{showRadSum}{Logical scalar, when \code{TRUE} show the weighted sum of slices 46 | below the label} 47 | 48 | \item{nrow, ncol}{Integer scalar, number of rows and columns for the grid} 49 | 50 | \item{byrow}{Logical scalar, fill the grid by rows when \code{TRUE}} 51 | 52 | \item{name, gp, vp}{Passed to \link[grid:grid.grob]{grid::gTree}} 53 | } 54 | \value{ 55 | \code{pieGrob} \link[grid:grid.grob]{grid::grob} object 56 | } 57 | \description{ 58 | Make grid of pieGrobs 59 | } 60 | \examples{ 61 | \donttest{ 62 | library(grid) 63 | 64 | s <- seq(0.2, 1, by = 0.1) 65 | smat <- do.call("rbind", replicate(20, s, simplify = FALSE)) 66 | grid.newpage() 67 | grid.pieGridGrob(radMat = smat) 68 | 69 | rownames(smat) <- sprintf("obs\%02d", 1:20) 70 | grid.newpage() 71 | grid.pieGridGrob(radMat = smat, wts = s) 72 | grid.newpage() 73 | grid.pieGridGrob(radMat = smat, wts = s, showRadSum = TRUE, labels = FALSE) 74 | grid.newpage() 75 | grid.pieGridGrob(radMat = smat, labels = "hello") 76 | grid.newpage() 77 | grid.pieGridGrob(radMat = smat, labels = 1:20) 78 | 79 | ## Can edit like normal grid objects 80 | grid.newpage() 81 | grid.pieGridGrob(radMat = smat, wts = s, showRadSum = TRUE) 82 | grid.ls() ## shows grid elements 83 | grid.edit("pie-20", fills = 1:9) 84 | grid.edit("pie-19-label", gp = gpar(font = 2, col = "red")) 85 | grid.edit("pie-1", wts = rep(1, 9), rads = rep(1, 9)) 86 | for (s in sprintf("pie-\%d-radSum", 2:4)) { 87 | grid.edit(s, gp = gpar(font = 2, col = "blue")) 88 | } 89 | } 90 | 91 | } 92 | -------------------------------------------------------------------------------- /R/allGenerics.R: -------------------------------------------------------------------------------- 1 | #' @importFrom BiocGenerics updateObject 2 | #' @importFrom BiocGenerics sort 3 | #' @importFrom BiocGenerics duplicated 4 | #' @importFrom BiocGenerics as.data.frame 5 | 6 | #' @name txpGenerics 7 | #' @title toxpiR package generics 8 | #' @description toxpiR package generics; see class man pages for associated 9 | #' methods 10 | #' @param x toxpiR S4 object 11 | #' @param value Replacement value 12 | #' @param ... Included for extendability; not currently used 13 | #' 14 | #' @return See specific methods for details. 15 | 16 | NULL 17 | 18 | #' @rdname txpGenerics 19 | setGeneric("txpValueNames", function(x, ...) standardGeneric("txpValueNames")) 20 | 21 | #' @rdname txpGenerics 22 | setGeneric("txpValueNames<-", 23 | function(x, ..., value) standardGeneric("txpValueNames<-")) 24 | 25 | #' @rdname txpGenerics 26 | setGeneric("txpTransFuncs", function(x, ...) standardGeneric("txpTransFuncs")) 27 | 28 | #' @rdname txpGenerics 29 | setGeneric("txpTransFuncs<-", 30 | function(x, ..., value) standardGeneric("txpTransFuncs<-")) 31 | 32 | #' @rdname txpGenerics 33 | setGeneric("txpSlices", function(x, ...) standardGeneric("txpSlices")) 34 | 35 | #' @rdname txpGenerics 36 | setGeneric("txpSlices<-", 37 | function(x, ..., value) standardGeneric("txpSlices<-")) 38 | 39 | #' @rdname txpGenerics 40 | setGeneric("txpWeights", function(x, ...) standardGeneric("txpWeights")) 41 | 42 | #' @rdname txpGenerics 43 | setGeneric("txpWeights<-", 44 | function(x, ..., value) standardGeneric("txpWeights<-")) 45 | 46 | #' @rdname txpCalculateScores 47 | setGeneric("txpCalculateScores", 48 | function(model, input, ...) standardGeneric("txpCalculateScores")) 49 | 50 | #' @rdname txpGenerics 51 | setGeneric("txpScores", function(x, ...) standardGeneric("txpScores")) 52 | 53 | #' @rdname txpGenerics 54 | setGeneric("txpSliceScores", function(x, ...) standardGeneric("txpSliceScores")) 55 | 56 | #' @rdname txpGenerics 57 | setGeneric("txpModel", function(x, ...) standardGeneric("txpModel")) 58 | 59 | #' @rdname txpGenerics 60 | setGeneric("txpIDs", function(x, ...) standardGeneric("txpIDs")) 61 | 62 | #' @rdname txpGenerics 63 | setGeneric("txpIDs<-", function(x, ..., value) standardGeneric("txpIDs<-")) 64 | 65 | #' @rdname txpGenerics 66 | setGeneric("txpRanks", function(x, ...) standardGeneric("txpRanks")) 67 | 68 | #' @rdname txpGenerics 69 | setGeneric("txpMissing", function(x, ...) standardGeneric("txpMissing")) 70 | 71 | #' @rdname txpGenerics 72 | setGeneric("txpResultParam", function(x, ...) standardGeneric("txpResultParam")) 73 | -------------------------------------------------------------------------------- /tests/testthat/test-txpExportGui.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## txpExportGui tests 3 | ##----------------------------------------------------------------------------## 4 | 5 | test_that("We can export GUI-ready files", { 6 | 7 | # Note1 8 | # Modifying transformation functions in the model causes the "columns are duplicated" 9 | # message to be repeated, I'm not sure if that is the desired response 10 | 11 | # Output file for txpExportGui() 12 | data_exported <- tempfile() 13 | # Load data and model 14 | expect_warning({ 15 | gui <- txpImportGui(file.path("guiFiles", "gui_output_data.csv")) 16 | }) 17 | # No warnings/errors expected for original imported file 18 | expect_silent({ 19 | txpExportGui( 20 | fileName = data_exported, 21 | input = gui$input, 22 | model = gui$model, 23 | id.var = 'Name', 24 | fills = gui$fills 25 | ) 26 | }) 27 | # Non-integer weights 28 | test_model <- gui$model 29 | expect_warning({ 30 | # See Note1 above 31 | txpWeights(test_model)[1] <- 0.5 32 | }) 33 | expect_error({ 34 | txpExportGui( 35 | fileName = data_exported, 36 | input = gui$input, 37 | model = test_model, 38 | id.var = 'Name', 39 | fills = gui$fills 40 | ) 41 | }) 42 | # Slice-level transformation function 43 | test_model <- gui$model 44 | expect_warning({ 45 | # See Note1 above 46 | txpTransFuncs(test_model)[[1]] <- function(x) log10(x) 47 | }) 48 | expect_warning({ 49 | txpExportGui( 50 | fileName = data_exported, 51 | input = gui$input, 52 | model = test_model, 53 | id.var = 'Name', 54 | fills = gui$fills 55 | ) 56 | }) 57 | # Input-level transformation function that creates negative values 58 | test_model <- gui$model 59 | expect_warning({ 60 | # See Note1 above 61 | txpTransFuncs(txpSlices(test_model)[[1]])[[1]] <- function(x) -x 62 | }) 63 | expect_warning({ 64 | txpExportGui( 65 | fileName = data_exported, 66 | input = gui$input, 67 | model = test_model, 68 | id.var = 'Name', 69 | fills = gui$fills 70 | ) 71 | }) 72 | # Negative input values, expect 3 warnings for the 3 affected slices 73 | test_input <- gui$input 74 | test_input[, 6] <- -test_input[, 6] 75 | expect_warning(expect_warning(expect_warning({ 76 | txpExportGui( 77 | fileName = data_exported, 78 | input = test_input, 79 | model = gui$model, 80 | id.var = 'Name', 81 | fills = gui$fills 82 | ) 83 | }))) 84 | }) 85 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(editDetails,pieGrob) 4 | export(TxpModel) 5 | export(TxpModelList) 6 | export(TxpResultList) 7 | export(TxpSlice) 8 | export(TxpSliceList) 9 | export(TxpTransFunc) 10 | export(TxpTransFuncList) 11 | export(as.TxpModelList) 12 | export(as.TxpResultList) 13 | export(as.TxpSliceList) 14 | export(as.TxpTransFuncList) 15 | export(grid.pieGridGrob) 16 | export(grid.pieGrob) 17 | export(pieGridGrob) 18 | export(pieGrob) 19 | export(txpCalculateScores) 20 | export(txpExportGui) 21 | export(txpImportGui) 22 | exportClasses(TxpModel) 23 | exportClasses(TxpModelList) 24 | exportClasses(TxpResult) 25 | exportClasses(TxpResultList) 26 | exportClasses(TxpResultParam) 27 | exportClasses(TxpSlice) 28 | exportClasses(TxpSliceList) 29 | exportClasses(TxpTransFunc) 30 | exportClasses(TxpTransFuncList) 31 | exportMethods("[") 32 | exportMethods("names<-") 33 | exportMethods("txpIDs<-") 34 | exportMethods("txpSlices<-") 35 | exportMethods("txpTransFuncs<-") 36 | exportMethods("txpValueNames<-") 37 | exportMethods("txpWeights<-") 38 | exportMethods(as.data.frame) 39 | exportMethods(duplicated) 40 | exportMethods(length) 41 | exportMethods(merge) 42 | exportMethods(names) 43 | exportMethods(plot) 44 | exportMethods(sort) 45 | exportMethods(txpCalculateScores) 46 | exportMethods(txpIDs) 47 | exportMethods(txpMissing) 48 | exportMethods(txpModel) 49 | exportMethods(txpRanks) 50 | exportMethods(txpResultParam) 51 | exportMethods(txpScores) 52 | exportMethods(txpSliceScores) 53 | exportMethods(txpSlices) 54 | exportMethods(txpTransFuncs) 55 | exportMethods(txpValueNames) 56 | exportMethods(txpWeights) 57 | import(ggplot2) 58 | import(grid) 59 | import(methods) 60 | importClassesFrom(S4Vectors,List) 61 | importClassesFrom(S4Vectors,SimpleList) 62 | importClassesFrom(S4Vectors,character_OR_NULL) 63 | importFrom(BiocGenerics,as.data.frame) 64 | importFrom(BiocGenerics,duplicated) 65 | importFrom(BiocGenerics,sort) 66 | importFrom(BiocGenerics,updateObject) 67 | importFrom(S4Vectors,List) 68 | importFrom(S4Vectors,classNameForDisplay) 69 | importFrom(S4Vectors,coolcat) 70 | importFrom(S4Vectors,new2) 71 | importFrom(S4Vectors,setValidity2) 72 | importFrom(grDevices,col2rgb) 73 | importFrom(grDevices,colorRampPalette) 74 | importFrom(grDevices,extendrange) 75 | importFrom(grDevices,rgb) 76 | importFrom(rlang,is_integerish) 77 | importFrom(rlang,is_named) 78 | importFrom(rlang,is_scalar_character) 79 | importFrom(rlang,is_scalar_integerish) 80 | importFrom(rlang,is_scalar_logical) 81 | importFrom(stats,sd) 82 | importFrom(tidyr,separate) 83 | importFrom(utils,data) 84 | importFrom(utils,read.csv) 85 | importFrom(utils,type.convert) 86 | importFrom(utils,write.table) 87 | -------------------------------------------------------------------------------- /man/TxpSliceList-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/allClasses.R, R/methods-TxpSliceList.R 3 | \docType{class} 4 | \name{TxpSliceList-class} 5 | \alias{TxpSliceList-class} 6 | \alias{TxpSliceList} 7 | \alias{txpValueNames,TxpSliceList-method} 8 | \alias{txpTransFuncs,TxpSliceList-method} 9 | \alias{duplicated,TxpSliceList-method} 10 | \alias{as.TxpSliceList} 11 | \title{List of TxpSlice objects} 12 | \usage{ 13 | TxpSliceList(...) 14 | 15 | \S4method{txpValueNames}{TxpSliceList}(x, simplify = FALSE) 16 | 17 | \S4method{txpTransFuncs}{TxpSliceList}(x, simplify = FALSE) 18 | 19 | \S4method{duplicated}{TxpSliceList}(x) 20 | 21 | as.TxpSliceList(x) 22 | } 23 | \arguments{ 24 | \item{...}{\link{TxpSlice} object to create \code{TxpSliceList} object; MUST give 25 | unique names to each slice} 26 | 27 | \item{x}{\code{TxpSliceList} object} 28 | 29 | \item{simplify}{Scalar logical, when \code{TRUE} the returned \code{list} is simplified 30 | to a \code{vector}/\link{TxpTransFuncList} object} 31 | } 32 | \description{ 33 | Extension of \link[S4Vectors:SimpleList-class]{S4Vectors::SimpleList} that requires 34 | uniquely-named elements and holds only \link{TxpSlice} objects. 35 | } 36 | \details{ 37 | Note, there is no coercion for \link{TxpSlice} to \code{TxpSliceList} because unique 38 | names are required. 39 | } 40 | \section{Functions}{ 41 | \itemize{ 42 | \item \code{txpValueNames(TxpSliceList)}: Return \code{list} of \code{txpValueNames} slots for the 43 | contained \link{TxpSlice} objects, or \code{vector} when \code{simplify = TRUE} 44 | 45 | \item \code{txpTransFuncs(TxpSliceList)}: Return \code{list} of \code{txpTransFuncs} slots for the 46 | contained \link{TxpSlice} objects, or \link{TxpTransFuncList} when \code{simplify = TRUE} 47 | 48 | \item \code{duplicated(TxpSliceList)}: Returns logical vector of \code{length(x)}, where 49 | \code{TRUE} indicates a duplicate slice in the list; see \link[base:duplicated]{base::duplicated} 50 | 51 | }} 52 | \examples{ 53 | ## Create TxpSlice objects 54 | s1 <- TxpSlice("input1", list(linear = function(x) x)) 55 | s2 <- TxpSlice(c("input2", "input3"), 56 | list(log = function(x) log(x), sqrt = function(x) sqrt(x))) 57 | 58 | ## Create TxpSliceList 59 | sl <- TxpSliceList(s1 = s1, s2 = s2) 60 | 61 | ## Accessors 62 | txpValueNames(sl) 63 | txpValueNames(sl, simplify = TRUE) 64 | 65 | txpTransFuncs(sl) 66 | txpTransFuncs(sl, simplify = TRUE) 67 | 68 | ## Coercion 69 | as(list(s1 = TxpSlice("hello"), s2 = TxpSlice("user")), "TxpSliceList") 70 | as.TxpSliceList(c(s1 = TxpSlice("hello"), s2 = TxpSlice("user"))) 71 | 72 | ## Concatenation 73 | c(sl, TxpSliceList(s3 = TxpSlice("input4"))) 74 | 75 | ## Reduce TxpSliceList to single slice 76 | Reduce(merge, sl) 77 | } 78 | -------------------------------------------------------------------------------- /tests/testthat/test-TxpModelList.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## TxpModelList tests 3 | ##----------------------------------------------------------------------------## 4 | 5 | ##----------------------------------------------------------------------------## 6 | ## Initialization 7 | 8 | test_that("We can create TxpModelList objects", { 9 | expect_silent(mdl <- TxpModel(TxpSliceList(s1 = TxpSlice("hello")))) 10 | expect_s4_class(TxpModelList(mdl, mdl), "TxpModelList") 11 | expect_s4_class(TxpModelList(m1 = mdl, m2 = mdl), "TxpModelList") 12 | expect_error(TxpModelList(mdl, NULL)) 13 | expect_error(TxpModelList(NULL)) 14 | expect_error(TxpModelList(3)) 15 | expect_length(TxpModelList(mdl, mdl, mdl), 3) 16 | expect_named(TxpModelList(mdl, m = mdl, mdl), c('', 'm', '')) 17 | }) 18 | 19 | ##----------------------------------------------------------------------------## 20 | ## Show 21 | 22 | test_that("TxpModelList show method displays correct information", { 23 | expect_silent({ 24 | mdl <- TxpModel(TxpSliceList(s1 = TxpSlice("hello"))) 25 | l <- TxpModelList(m1 = mdl, mdl, m3 = mdl) 26 | }) 27 | expect_output(print(l), "TxpModelList of length 3") 28 | expect_output(print(l), "m1 '' m3") 29 | expect_silent(names(l) <- NULL) 30 | expect_output(print(l), "'' '' ''") 31 | }) 32 | 33 | ##----------------------------------------------------------------------------## 34 | ## Concatenation 35 | 36 | test_that("We can concatenate TxpModelList objects", { 37 | expect_silent({ 38 | mdl <- TxpModel(TxpSliceList(s1 = TxpSlice("hello"))) 39 | l <- TxpModelList(m1 = mdl, mdl, m3 = mdl) 40 | }) 41 | expect_s4_class(cl <- c(l, rev(l), l), "TxpModelList") 42 | expect_length(cl, 9) 43 | expect_named(cl, c('m1', '', 'm3', 'm3', '', 'm1', 'm1', '', 'm3')) 44 | }) 45 | 46 | ##----------------------------------------------------------------------------## 47 | ## Coercion 48 | 49 | test_that("We can coerce to TxpModelList objects", { 50 | expect_silent({ 51 | mdl <- TxpModel(TxpSliceList(s1 = TxpSlice("hello"))) 52 | l <- list(m1 = mdl, mdl, m3 = mdl) 53 | }) 54 | expect_s4_class(as.TxpModelList(l), "TxpModelList") 55 | expect_s4_class(as.TxpModelList(l[[1]]), "TxpModelList") 56 | }) 57 | 58 | ##----------------------------------------------------------------------------## 59 | ## Duplicated 60 | 61 | test_that("We can detect duplicate TxpModel objects in TxpModelList", { 62 | m1 <- TxpModel(c(S1 = TxpSlice("inpt1"))) 63 | m2 <- TxpModel(c(S1 = TxpSlice("inpt1"), S2 = TxpSlice("inpt2"))) 64 | m3 <- TxpModel(c(S1 = TxpSlice("inpt1")), 2) 65 | expect_false(any(duplicated(TxpModelList(m1 = m1, m2 = m2, m3 = m3)))) 66 | expect_true(any(duplicated(TxpModelList(m1 = m1, m2 = m1)))) 67 | }) 68 | -------------------------------------------------------------------------------- /R/methods-TxpResultList.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## methods-txpResultList 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name TxpResultList-class 6 | #' @title List of TxpResult objects 7 | #' @description Extension of [S4Vectors::SimpleList] that holds only [TxpResult] 8 | #' objects. 9 | #' 10 | #' @param ... [TxpResult] object to create `TxpResultList` object 11 | #' @param x `TxpResultList` object 12 | #' 13 | #' @template roxgn-loadExamples 14 | #' @template roxgn-calcTxpModelList 15 | #' 16 | #' @seealso [TxpResult], [txpCalculateScores] 17 | #' 18 | #' @examples 19 | #' ## duplicated 20 | #' duplicated(resLst) 21 | #' 22 | #' ## Coercion 23 | #' as(list(resLst[[1]], resLst[[2]]), "TxpResultList") 24 | #' as.TxpResultList(list(res1 = resLst[[1]], res2 = resLst[[2]])) 25 | #' 26 | #' as(resLst[[1]], "TxpResultList") 27 | #' as.TxpResultList(resLst[[1]]) 28 | 29 | NULL 30 | 31 | ##----------------------------------------------------------------------------## 32 | ## constructor 33 | 34 | #' @rdname TxpResultList-class 35 | #' @export 36 | 37 | TxpResultList <- function(...) { 38 | listData <- list(...) 39 | new2("TxpResultList", listData) 40 | } 41 | 42 | ##----------------------------------------------------------------------------## 43 | ## validity 44 | 45 | .TxpResultList.validity <- function(object) { 46 | msg <- NULL 47 | valid <- vapply(object@listData, is, logical(1), "TxpResult") 48 | if (any(!valid)) { 49 | msg <- c(msg, "All TxpResult objects must be of class 'TxpResult.'") 50 | } 51 | if (is.null(msg)) return(TRUE) 52 | msg 53 | } 54 | 55 | setValidity2("TxpResultList", .TxpResultList.validity) 56 | 57 | ##----------------------------------------------------------------------------## 58 | ## show 59 | 60 | .TxpResultList.show <- function(object) { 61 | lnms <- .listDisplayNames(object) 62 | .coolcat(" TxpResultList of length %d: %s\n", lnms) 63 | } 64 | 65 | setMethod("show", "TxpResultList", .TxpResultList.show) 66 | 67 | ##----------------------------------------------------------------------------## 68 | ## duplicated 69 | 70 | #' @rdname TxpResultList-class 71 | #' @export 72 | 73 | setMethod("duplicated", "TxpResultList", function(x) .dupList(x)) 74 | 75 | ##----------------------------------------------------------------------------## 76 | ## coercion 77 | 78 | .TxpResultList.from.list <- function(from) { 79 | do.call("TxpResultList", from) 80 | } 81 | 82 | setAs("list", "TxpResultList", .TxpResultList.from.list) 83 | 84 | .TxpResultList.from.TxpResult <- function(from) { 85 | TxpResultList(from) 86 | } 87 | 88 | setAs("TxpResult", "TxpResultList", .TxpResultList.from.TxpResult) 89 | 90 | #' @rdname TxpResultList-class 91 | #' @export 92 | 93 | as.TxpResultList <- function(x) as(x, "TxpResultList") 94 | 95 | ##----------------------------------------------------------------------------## 96 | 97 | 98 | -------------------------------------------------------------------------------- /tests/testthat/test-TxpTransFuncList.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## TxpTransFuncList tests 3 | ##----------------------------------------------------------------------------## 4 | 5 | ##----------------------------------------------------------------------------## 6 | ## Initialization 7 | 8 | test_that("We can create TxpTransFuncList objects", { 9 | expect_s4_class(TxpTransFuncList(TxpTransFunc()), "TxpTransFuncList") 10 | expect_s4_class(TxpTransFuncList(f = TxpTransFunc()), "TxpTransFuncList") 11 | expect_s4_class(TxpTransFuncList(function(x) x), "TxpTransFuncList") 12 | expect_s4_class(TxpTransFuncList(NULL), "TxpTransFuncList") 13 | f <- function(x) x 14 | expect_s4_class(l <- TxpTransFuncList(NULL, NULL, f1 = f, f, NULL), 15 | "TxpTransFuncList") 16 | expect_length(l, 5) 17 | expect_named(l, c('', '', 'f1', '', '')) 18 | expect_error(TxpTransFuncList(NULL, "a")) 19 | expect_error(TxpTransFuncList(function(x) "a")) 20 | expect_silent(l <- as.list(l)) 21 | expect_s4_class(as.TxpTransFuncList(l), "TxpTransFuncList") 22 | expect_s4_class(as(l, "TxpTransFuncList"), "TxpTransFuncList") 23 | expect_s4_class(as.TxpTransFuncList(function(x) x), "TxpTransFuncList") 24 | expect_s4_class(as(function(x) x, "TxpTransFuncList"), "TxpTransFuncList") 25 | }) 26 | 27 | ##----------------------------------------------------------------------------## 28 | ## Show 29 | 30 | test_that("TxpTransFuncList show method displays correct information", { 31 | expect_silent(f <- function(x) x) 32 | expect_silent(l <- TxpTransFuncList(NULL, NULL, f1 = f, f, NULL)) 33 | expect_output(print(l), "TxpTransFuncList of length 5") 34 | expect_output(print(l), "NULL NULL f1 '' NULL") 35 | expect_silent(names(l) <- NULL) 36 | expect_output(print(l), "NULL NULL '' '' NULL") 37 | }) 38 | 39 | ##----------------------------------------------------------------------------## 40 | ## Concatenation 41 | 42 | test_that("We can concatenate TxpTransFuncList objects", { 43 | expect_silent({ 44 | f <- TxpTransFunc() 45 | l <- TxpTransFuncList(f = f, f, NULL) 46 | }) 47 | expect_s4_class(cl <- c(l, rev(l), l), "TxpTransFuncList") 48 | expect_length(cl, 9) 49 | expect_named(cl, c('f', '', '', '', '', 'f', 'f', '', '')) 50 | }) 51 | 52 | ##----------------------------------------------------------------------------## 53 | ## Replacement 54 | 55 | test_that("We can replace TxpTransFuncList objects", { 56 | expect_silent({ 57 | f <- TxpTransFunc() 58 | l <- TxpTransFuncList(f = f, f, NULL) 59 | }) 60 | expect_s4_class({l[[2]] <- function(x) x^2; l}, "TxpTransFuncList") 61 | expect_equal(l[[2]](10), 100) 62 | expect_error(l[[2]] <- "a") 63 | expect_error(l[[2]] <- function(x) x + "hello") 64 | expect_s4_class({l[2:3] <- list(function(x) x, function(x) sqrt(x)); l}, 65 | "TxpTransFuncList") 66 | expect_equal(l[[2]](10), 10) 67 | expect_equal(l[[3]](100), 10) 68 | expect_length({l[2] <- list(NULL); l}, 3) 69 | expect_output(print(l), "f NULL ''") 70 | expect_length({l[[1]] <- NULL; l}, 2) 71 | expect_output(print(l), "NULL ''") 72 | }) 73 | 74 | 75 | -------------------------------------------------------------------------------- /tests/testthat/test-TxpSliceList.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## TxpSliceList tests 3 | ##----------------------------------------------------------------------------## 4 | 5 | ##----------------------------------------------------------------------------## 6 | ## Initialization 7 | 8 | test_that("We can create TxpSliceList objects", { 9 | expect_s4_class(TxpSliceList(), "TxpSliceList") 10 | expect_s4_class(TxpSliceList(S1 = TxpSlice("inpt1"), S2 = TxpSlice("inpt2")), 11 | "TxpSliceList") 12 | expect_error(TxpSliceList(TxpSlice("inpt1"))) 13 | expect_error(TxpSliceList(S1 = TxpSlice("inpt1"), S1 = TxpSlice("inpt2"))) 14 | expect_error(TxpSliceList(NULL)) 15 | expect_error(TxpSliceList("a")) 16 | }) 17 | 18 | test_that("We can coerce list to TxpSliceList", { 19 | l <- list(S1 = TxpSlice("inpt1"), S2 = TxpSlice("inpt2")) 20 | expect_s4_class(as.TxpSliceList(l), "TxpSliceList") 21 | }) 22 | 23 | ##----------------------------------------------------------------------------## 24 | ## Accessors 25 | 26 | test_that("We can access TxpSlice slots from TxpSliceList", { 27 | sl <- TxpSliceList(S1 = TxpSlice("inpt1"), S2 = TxpSlice(c("inpt2", "inpt3"))) 28 | expect_type(txpValueNames(sl), "list") 29 | expect_length(txpValueNames(sl), 2) 30 | expect_type(txpValueNames(sl, simplify = TRUE), "character") 31 | expect_length(txpValueNames(sl, simplify = TRUE), 3) 32 | expect_type(txpTransFuncs(sl), "list") 33 | expect_length(txpTransFuncs(sl), 2) 34 | expect_s4_class(txpTransFuncs(sl, simplify = TRUE), "TxpTransFuncList") 35 | expect_length(txpTransFuncs(sl, simplify = TRUE), 3) 36 | }) 37 | 38 | ##----------------------------------------------------------------------------## 39 | ## Duplicated 40 | 41 | test_that("We can detect duplicate TxpSlice objects in TxpSliceList", { 42 | s1 <- TxpSlice("inpt1") 43 | s2 <- TxpSlice("inpt1") 44 | s3 <- TxpSlice("inpt1", txpTransFuncs = function(x) x^2) 45 | expect_true(any(duplicated(TxpSliceList(s1 = s2, s2 = s2)))) 46 | expect_false(any(duplicated(TxpSliceList(s1 = s1, s3 = s3)))) 47 | }) 48 | 49 | ##----------------------------------------------------------------------------## 50 | ## Replacement 51 | 52 | test_that("We can replace TxpSliceList objects", { 53 | expect_silent({ 54 | s <- TxpSlice("inpt1") 55 | l <- TxpSliceList(s1 = s, s2 = s, s3 = s) 56 | }) 57 | expect_s4_class({l[[1]] <- TxpSlice("hello"); l}, "TxpSliceList") 58 | expect_equal(txpValueNames(l[[1]]), "hello") 59 | expect_error(l[[2]] <- "a") 60 | expect_error(l[2] <- list(NULL)) 61 | expect_error(l[2:3] <- list(TxpSlice("inpt2"), TxpSlice("inpt3"))) 62 | expect_s4_class({ 63 | l[2:3] <- list(s4 = TxpSlice("inpt2"), s5 = TxpSlice("inpt3")) 64 | l 65 | }, "TxpSliceList") 66 | expect_named(l, c("s1", "s2", "s3")) 67 | expect_equal(txpValueNames(l, simplify = TRUE), 68 | c(s1 = "hello", s2 = "inpt2", s3 = "inpt3")) 69 | expect_named({names(l) <- c("a", "b", "c"); l}, c("a", "b", "c")) 70 | expect_named({names(l)[1] <- "hello"; l}, c("hello", "b", "c")) 71 | expect_named({names(l)[1:2] <- c("a", "hello"); l}, c("a", "hello", "c")) 72 | expect_length({l[2] <- NULL; l}, 2) 73 | expect_equal(txpValueNames(l, simplify = TRUE), c(a = "hello", c = "inpt3")) 74 | }) 75 | -------------------------------------------------------------------------------- /man/txpCalculateScores.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/allGenerics.R, R/methods-TxpModel.R, 3 | % R/methods-TxpModelList.R, R/txpCalculateScores.R 4 | \name{txpCalculateScores} 5 | \alias{txpCalculateScores} 6 | \alias{txpCalculateScores,TxpModel,data.frame-method} 7 | \alias{txpCalculateScores,TxpModelList,data.frame-method} 8 | \alias{txpCalculateScores,list,data.frame-method} 9 | \title{Calculate ToxPi Scores for the given model and input data} 10 | \usage{ 11 | txpCalculateScores(model, input, ...) 12 | 13 | \S4method{txpCalculateScores}{TxpModel,data.frame}( 14 | model, 15 | input, 16 | id.var = NULL, 17 | rank.ties.method = c("average", "first", "last", "random", "max", "min"), 18 | negative.value.handling = c("keep", "missing") 19 | ) 20 | 21 | \S4method{txpCalculateScores}{TxpModelList,data.frame}( 22 | model, 23 | input, 24 | id.var = NULL, 25 | rank.ties.method = c("average", "first", "last", "random", "max", "min"), 26 | negative.value.handling = c("keep", "missing") 27 | ) 28 | 29 | \S4method{txpCalculateScores}{list,data.frame}( 30 | model, 31 | input, 32 | id.var = NULL, 33 | rank.ties.method = c("average", "first", "last", "random", "max", "min"), 34 | negative.value.handling = c("keep", "missing") 35 | ) 36 | } 37 | \arguments{ 38 | \item{model}{\link{TxpModel} object or \link{TxpModelList} object} 39 | 40 | \item{input}{data.frame object containing the model input data} 41 | 42 | \item{...}{Included for extendability; not currently used} 43 | 44 | \item{id.var}{Character scalar, column in 'input' to store in} 45 | 46 | \item{rank.ties.method}{Passed to \code{rank.ties.method} slot} 47 | 48 | \item{negative.value.handling}{Passed to \code{negative.value.handling} slot} 49 | } 50 | \value{ 51 | \link{TxpResult} or \link{TxpResultList} object 52 | } 53 | \description{ 54 | Calculate ToxPi Scores for the given model and input data 55 | } 56 | \details{ 57 | \code{txpCalculateScores} is implemented as an S4 generic function with methods 58 | for \link{TxpModel} and \link{TxpModelList}. 59 | 60 | Ranks are calculated such that the highest ToxPi score has a rank of 1. 61 | 62 | Missingness is determined after applying input-level transformations but 63 | before applying slice-level transformations. 64 | } 65 | \examples{ 66 | ## Load example dataset & model; see ?TxpModel for building model objects 67 | data(txp_example_input, package = "toxpiR") 68 | data(txp_example_model, package = "toxpiR") 69 | 70 | ## Calculate scores for single model; returns TxpResult object 71 | res <- txpCalculateScores(model = txp_example_model, 72 | input = txp_example_input, 73 | id.var = "name") 74 | 75 | ## Calculate scores for list of models; returns TxpResultList object 76 | txpCalculateScores(model = TxpModelList(m1 = txp_example_model, 77 | m2 = txp_example_model), 78 | input = txp_example_input, 79 | id.var = "name") 80 | resLst <- txpCalculateScores(model = list(m1 = txp_example_model, 81 | m2 = txp_example_model), 82 | input = txp_example_input, 83 | id.var = "name") 84 | 85 | } 86 | \seealso{ 87 | \link{TxpModel}, \link{TxpResult}, \link{TxpResultParam} 88 | } 89 | -------------------------------------------------------------------------------- /vignettes/importFromGui.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Import ToxPi GUI Files" 3 | output: rmarkdown::html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Import ToxPi GUI Files} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | %\VignetteEncoding{UTF-8} 8 | --- 9 | 10 | ```{r, include = FALSE} 11 | knitr::opts_chunk$set( 12 | collapse = TRUE, 13 | comment = "#>" 14 | ) 15 | ``` 16 | 17 | This vignette will show how to load a data file that was saved using the ToxPi Java GUI, which can be downloaded from [here](https://toxpi.org/). The ToxPi Java GUI will save data files using file format "C" described in the ToxPi User Manual. This vignette will use the "format_C.csv" file to demonstrate how to import GUI data. 18 | 19 | ```{r setup} 20 | library(toxpiR) 21 | 22 | ## Create a tempfile and download 'format_C.csv' 23 | fmtc <- tempfile() 24 | ghuc <- "https://raw.githubusercontent.com" 25 | fmtcUrl <- file.path(ghuc, "ToxPi", "ToxPi-example-files", "main", "format_C.csv") 26 | download.file(url = fmtcUrl, destfile = fmtc, quiet = TRUE) 27 | ``` 28 | 29 | The "format_C.csv" model specification reuses metrics across different slices. 30 | In general, we do not recommend duplicating inputs across slices, so the user gets a warning when creating a model with duplicate inputs. 31 | 32 | ```{r} 33 | ## Import file into R 34 | gui <- txpImportGui(fmtc) 35 | 36 | ``` 37 | 38 | The resulting `list` object contains: `$model`, a `TxpModel` object with the model specifications; `$input`, a `data.frame` containing the data for calculating ToxPi scores; and `$fills`, an array of slice colors for plotting. 39 | 40 | ```{r} 41 | gui$model 42 | gui$input 43 | gui$fills 44 | ``` 45 | 46 | We calculate ToxPi scores using the `txpCalculateScores` function, which takes a model and input `data.frame`. 47 | Note that by default the ToxPi GUI does not accept negative values. However, the package keeps them by default. 48 | To replicate the GUI functionailty, we set `negative.value.handling = "missing"`. 49 | 50 | ```{r} 51 | ## Calculate ToxPi scores 52 | res <- txpCalculateScores(model = gui$model, input = gui$input, id.var = "Name",negative.value.handling = "missing") 53 | 54 | ## Overall ToxPi scores 55 | txpScores(res) 56 | 57 | ## Slice scores 58 | txpSliceScores(res, adjusted = FALSE) 59 | ``` 60 | 61 | A results output similar to that given by the Java GUI can be obtained by combining score components. 62 | 63 | ```{r} 64 | out <- as.data.frame(res, adjusted = FALSE) 65 | out <- out[order(out$score, decreasing = TRUE), ] 66 | out 67 | ``` 68 | 69 | ToxPi images and overall score rank plot can also be produced. 70 | 71 | ```{r fig.width = 7} 72 | plot(sort(res), fills = gui$fills) 73 | ``` 74 | 75 | ```{r fig.width = 7, fig.height = 4} 76 | plot(res, txpRanks(res)) 77 | plot(res, txpRanks(res), labels = 1:10, pch = 16, size = grid::unit(0.75, "char")) 78 | ``` 79 | 80 | The basic clustering methods offered in the Java GUI can also be recreated. 81 | 82 | ```{r fig.width = 7, fig.height = 5} 83 | ## Hierarchical Clustering 84 | hc <- hclust(dist(txpSliceScores(res)), method = 'complete') 85 | plot(hc, hang = -1, labels = txpIDs(res), xlab = 'Name', sub = '') 86 | ``` 87 | 88 | ```{r fig.width = 7, fig.height = 5} 89 | ## K-Means Clustering, plotted using principal components 90 | nClusters <- 3 91 | km <- kmeans(txpSliceScores(res), nClusters) 92 | pc <- prcomp(txpSliceScores(res)) 93 | coord <- predict(pc) * -sum(txpWeights(res)) 94 | plot(coord[,1], coord[,2], col = km$cluster, 95 | xlab = 'PC1', ylab = 'PC2', pch = 16) 96 | ``` 97 | -------------------------------------------------------------------------------- /tests/testthat/test-TxpSlice.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## TxpSlice tests 3 | ##----------------------------------------------------------------------------## 4 | 5 | ##----------------------------------------------------------------------------## 6 | ## Initialization 7 | 8 | test_that("We can create TxpSlice objects", { 9 | vnames <- c("input1", "input2", "input3") 10 | tfuncs <- TxpTransFuncList(f1 = TxpTransFunc(), f2 = NULL, f3 = NULL) 11 | expect_s4_class(TxpSlice(txpValueNames = vnames), "TxpSlice") 12 | expect_s4_class(TxpSlice(txpValueNames = vnames, txpTransFuncs = tfuncs), 13 | "TxpSlice") 14 | expect_warning(recycle <- TxpSlice(c("a", "b", "c"), function(x) x)) 15 | expect_s4_class(recycle, "TxpSlice") 16 | expect_length(txpTransFuncs(recycle), 3) 17 | expect_error(TxpSlice()) 18 | expect_error(TxpSlice(NA)) 19 | expect_error(TxpSlice(NULL)) 20 | expect_error(TxpSlice(c("x", "x"))) 21 | expect_error(TxpSlice(vnames, tfuncs[1:2])) 22 | }) 23 | 24 | ##----------------------------------------------------------------------------## 25 | ## Accessors 26 | 27 | test_that("TxpSlice accessors return expected slots", { 28 | sl <- TxpSlice(txpValueNames = c("input1", "input2", "input3"), 29 | txpTransFuncs = TxpTransFuncList(f1 = TxpTransFunc(), 30 | f2 = NULL, 31 | f3 = NULL)) 32 | expect_s4_class(txpTransFuncs(sl), "TxpTransFuncList") 33 | expect_equal(txpValueNames(sl), c("input1", "input2", "input3")) 34 | }) 35 | 36 | ##----------------------------------------------------------------------------## 37 | ## Replace 38 | 39 | test_that("We can replace TxpSlice slots", { 40 | sl <- TxpSlice("input1") 41 | expect_s4_class({txpValueNames(sl) <- "input2"; sl}, "TxpSlice") 42 | expect_equal(txpValueNames(sl), "input2") 43 | expect_error(txpValueNames(sl) <- 3) 44 | expect_error(txpValueNames(sl) <- c("a", "b")) 45 | expect_s4_class({txpTransFuncs(sl) <- function(x) x; sl}, "TxpSlice") 46 | expect_s4_class({names(txpTransFuncs(sl)) <- "linear"; sl}, "TxpSlice") 47 | expect_equal(txpTransFuncs(sl)[[1]](10), 10) 48 | expect_named(txpTransFuncs(sl), "linear") 49 | }) 50 | 51 | 52 | ##----------------------------------------------------------------------------## 53 | ## Show 54 | 55 | test_that("TxpSlice shows correct information", { 56 | sl <- TxpSlice(c("input1", "input2"), list(f1 = function(x) x, NULL)) 57 | expect_output(print(sl), "txpValueNames\\(2\\)") 58 | expect_output(print(sl), "input1 input2") 59 | expect_output(print(sl), "txpTransFuncs\\(2\\)") 60 | expect_output(print(sl), "f1 NULL") 61 | }) 62 | 63 | ##----------------------------------------------------------------------------## 64 | ## Length 65 | 66 | test_that("TxpSlice length returns correct length", { 67 | expect_equal(length(TxpSlice(letters)), 26) 68 | expect_equal(length(TxpSlice(letters[1:5])), 5) 69 | }) 70 | 71 | ##----------------------------------------------------------------------------## 72 | ## Merge 73 | 74 | test_that("We can merge two TxpSlice objects", { 75 | s1 <- TxpSlice(c("input1", "input2"), list(NULL, linear = function(x) x)) 76 | s2 <- TxpSlice(c("input3", "input4"), list(NULL, linear = function(x) x)) 77 | expect_s4_class(smrg <- merge(s1, s2), "TxpSlice") 78 | expect_equal(txpValueNames(smrg), c("input1", "input2", "input3", "input4")) 79 | expect_named(txpTransFuncs(smrg), c("", "linear", "", "linear")) 80 | }) 81 | -------------------------------------------------------------------------------- /R/methods-TxpResultParam.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## methods-TxpResultParam 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name TxpResultParam-class 6 | #' @aliases TxpResultParam 7 | #' @title ToxPi Result Parameters 8 | #' @description S4 class to store ToxPi result calculation parameters 9 | #' 10 | #' @slot rank.ties.method Character scalar, method used to calculate score 11 | #' ranks passed to [base::rank] 12 | #' @slot negative.value.handling Character scalar, how negative values are 13 | #' handled, see details 14 | #' 15 | #' @param rank.ties.method Passed to `rank.ties.method` slot 16 | #' @param negative.value.handling Passed to `negative.value.handling` slot 17 | #' 18 | #' @details 19 | #' If more than one value is passed to `TxoResultParam` scalar options, e.g. 20 | #' `rank.ties.method`, only the first value is kept. 21 | #' 22 | #' The `rank.ties.method` slot is passed to [base::rank] for calculating the 23 | #' ranks of observations, with the highest-scoring observation having the rank 24 | #' of 1. 25 | #' 26 | #' `negative.value.handling` indicates how to handle negative values in the 27 | #' inputs. The ToxPi algorithm originally intended to accept non-negative 28 | #' potency values; the GUI, therefore, treats negative values in the input as 29 | #' missing. By default, [txpCalculateScores] keeps negative values 30 | #' (`negative.value.handling = "keep"`). To replicate the GUI behavior, users 31 | #' can set `negative.value.handling = "missing"`. 32 | #' 33 | #' @seealso [txpCalculateScores], [TxpResult] 34 | #' 35 | 36 | NULL 37 | 38 | ##----------------------------------------------------------------------------## 39 | ## constructor -- NOT exported 40 | 41 | TxpResultParam <- function(rank.ties.method, negative.value.handling) { 42 | new2("TxpResultParam", 43 | rank.ties.method = rank.ties.method[1], 44 | negative.value.handling = negative.value.handling[1]) 45 | } 46 | 47 | ##----------------------------------------------------------------------------## 48 | ## validity 49 | 50 | #' @importFrom rlang is_scalar_character 51 | 52 | .TxpResultParam.validity <- function(object) { 53 | msg <- NULL 54 | rankMthd <- slot(object, "rank.ties.method") 55 | if (!is_scalar_character(rankMthd)) { 56 | msg <- c(msg, "rank.ties.method must be scalar character") 57 | } 58 | validRnkMthd <- c("average", "first", "last", "random", "max", "min") 59 | if (is_scalar_character(rankMthd) && !rankMthd %in% validRnkMthd) { 60 | msg <- c(msg, "Invalid rank.ties.method; see ?base::rank") 61 | } 62 | negHndl <- slot(object, "negative.value.handling") 63 | if (!is_scalar_character(negHndl)) { 64 | msg <- c(msg, "negative.value.handling must be scalar character") 65 | } 66 | validNegHndl <- c("keep", "missing") 67 | if (is_scalar_character(negHndl) && !negHndl %in% validNegHndl) { 68 | msg <- c(msg, "Invalid negative.value.handling; see ?TxpResultParam") 69 | } 70 | if (is.null(msg)) return(TRUE) 71 | msg 72 | } 73 | 74 | setValidity2("TxpResultParam", .TxpResultParam.validity) 75 | 76 | ##----------------------------------------------------------------------------## 77 | ## show 78 | 79 | .TxpResultParam.show <- function(object) { 80 | cat("TxpResultParam:\n") 81 | sapply(names(getSlots("TxpResultParam")), .catslot, object = object) 82 | } 83 | 84 | setMethod("show", "TxpResultParam", .TxpResultParam.show) 85 | 86 | 87 | ##----------------------------------------------------------------------------## 88 | 89 | 90 | 91 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | ##---------------------------------------------------------------------------## 2 | ## Non-exported, non-documented, package-wide utility functions 3 | ##---------------------------------------------------------------------------## 4 | 5 | #' @importFrom S4Vectors coolcat 6 | 7 | .coolcat <- function(...) coolcat(..., indent = 2) 8 | 9 | .catslot <- function(x, object) { 10 | cat(" ", x, ":", " ", slot(object = object, name = x), "\n", sep = "") 11 | } 12 | 13 | .repFunc <- function(func, times) { 14 | lst <- vector(mode = "list", length = times) 15 | for (i in 1:times) lst[[i]] <- func 16 | do.call("TxpTransFuncList", lst) 17 | } 18 | 19 | .listDisplayNames <- function(x) { 20 | n <- length(x) 21 | lnms <- names(x) 22 | if (is.null(lnms)) lnms <- rep('', n) 23 | lnms[sapply(x, is.null)] <- "NULL" 24 | lnms 25 | } 26 | 27 | .dupList <- function(x) { 28 | duplicated(as.list(x)) 29 | } 30 | 31 | .chkModelInput <- function(model, input) { 32 | stopifnot(is(model, "TxpModel")) 33 | stopifnot(is.data.frame(input)) 34 | valNms <- txpValueNames(model, simplify = TRUE) 35 | inptNms <- names(input) 36 | if (!all(valNms %in% inptNms)) { 37 | miss <- valNms[!valNms %in% inptNms] 38 | msg <- "'input' missing the following data specified by 'model':\n %s" 39 | stop(sprintf(msg, paste(miss, collapse = ", "))) 40 | } 41 | tstClass <- function(x) is.numeric(input[[x]]) 42 | inptCls <- sapply(valNms, tstClass) 43 | if (!all(inptCls)) { 44 | nc2n <- valNms[!inptCls] 45 | msg <- "The following 'input' columns not numeric:\n %s" 46 | stop(sprintf(msg, paste(nc2n, collapse = ", "))) 47 | } 48 | } 49 | 50 | .rmInfinite <- function(model, input) { 51 | ## Clean up infinite in input 52 | valNms <- txpValueNames(txpSlices(model), simplify = TRUE) 53 | notFinite <- sapply(valNms, function(x) any(is.infinite(input[[x]]))) 54 | if (any(notFinite)) { 55 | warning("Some of the given inputs contained infinite values.") 56 | for (i in valNms[notFinite]) input[[i]][is.infinite(input[[i]])] <- NaN 57 | } 58 | input 59 | } 60 | 61 | #' @importFrom grDevices col2rgb rgb 62 | 63 | .col2hex <- function(x) { 64 | mat <- col2rgb(x) 65 | rgb(red = mat[1, ], green = mat[2, ], blue = mat[3, ], maxColorValue = 255) 66 | } 67 | 68 | # replicated pryr functions 69 | 70 | .to_env <- function(x, quiet = FALSE) { 71 | if (is.environment(x)) { 72 | x 73 | } else if (is.list(x)) { 74 | list2env(x) 75 | } else if (is.function(x)) { 76 | environment(x) 77 | } else if (length(x) == 1 && is.character(x)) { 78 | if (!quiet) message("Using environment ", x) 79 | as.environment(x) 80 | } else if (length(x) == 1 && is.numeric(x) && x > 0) { 81 | if (!quiet) message("Using environment ", search()[x]) 82 | as.environment(x) 83 | } else { 84 | stop("Input can not be coerced to an environment", call. = FALSE) 85 | } 86 | } 87 | 88 | .substitute_q <- function(x, env) { 89 | stopifnot(is.language(x)) 90 | env <- .to_env(env) 91 | 92 | call <- substitute(substitute(x, env), list(x = x)) 93 | eval(call) 94 | 95 | } 96 | 97 | .make_function <- function(args, body, env = parent.frame()) { 98 | args <- as.pairlist(args) 99 | stopifnot( 100 | .all_named(args), 101 | is.language(body)) 102 | env <- .to_env(env) 103 | 104 | eval(call("function", args, body), env) 105 | } 106 | 107 | .all_named <- function(x) { 108 | if (length(x) == 0) return(TRUE) 109 | !is.null(names(x)) && all(names(x) != "") 110 | } 111 | ##----------------------------------------------------------------------------## 112 | 113 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing Guide 2 | 3 | Filing issues 4 | ------------- 5 | 6 | Please read these points carefully and follow them while filing issues. 7 | 8 | - **One issue for one purpose**. Don't add more than one *bug*, *feature request*, or *documentation request* on to the same issue. Take the time to read through the current issues to ensure your issue is not already listed. 9 | - If you've found a *bug*, thank you for reporting! Please include a reproducible example of your bug in the issue. 10 | - If you need *support* or have a general *question*, please consider asking the question on [StackOverflow](http://www.stackoverflow.com) 11 | - For the project contributors, please label new issues using the following rules: 12 | - *bugs* should be labeled "bug" 13 | - *feature requests* or *suggestions* should be labeled "enhancement" 14 | - *questions* or *requests for support* should be labeled "question" 15 | 16 | Pull Requests 17 | ------------- 18 | 19 | Please file an issue before creating PRs so that it can be discussed first *before* you invest time implementing it. 20 | 21 | 1. Please create all pull requests (PR) against the `dev` branch. 22 | 2. Create **one PR per feature/bug fix**. Each PR should be associated with an Issue. 23 | 3. Create a branch for that feature/bug fix, named 'issue-N' where N is the Issue number, and use that as a base for your pull requests. Pull requests directly against your version of `dev/main` will not be accepted. 24 | 4. Please squash temporary stage commits together before issuing a PR. 25 | 5. All commit messages should have two components: (1) a headerer on the first line beginning with "issue-N:" and containing no more than 50 characters, and (2) a body with 1 empty line after the header then at least a sentence or two in the commit body detailing all changes and justifications. Lines in the commit body should be wrapped to no more than 72 characters per line, and can contain multiple paragraphs.[1](#myfootnote1) 26 | 5. In your pull request's description, please state clearly as to what your PR does, i.e., what FR or bug your PR addresses, along with the issue number. For e.g, "Closes #717: tcplLoadData no longer errors with missing data." 27 | 7. Please build and test the package using `R CMD check --as-cran` against your branch source package archive `.tar.gz` file. You may want to add `--no-manual`, `--no-build-vignettes` or `--ignore-vignettes` (R 3.3.0+) options to reduce dependencies required to perform check. PRs that fail `check` cannot be merged. Additionally, check the tests using `devtools::test()` and ensure they pass or the failing tests are updated appropriately 28 | 8. The NEWS file also has to be updated while fixing or implementing an issue. It should mention the issue number and what the issue is being closed. Also add a "Thanks to @your_name for the PR". 29 | 30 | **References:** If you are not sure how to issue a PR, but would like to contribute, these links should help get you started: 31 | 32 | 1. **[How to Github: Fork, Branch, Track, Squash and Pull request](https://gun.io/blog/how-to-github-fork-branch-and-pull-request/)**. 33 | 2. **[Squashing Github pull requests into a single commit](http://eli.thegreenplace.net/2014/02/19/squashing-github-pull-requests-into-a-single-commit)**. 34 | 35 | *This guide was modified from the contributing guide for the [data.table](https://github.com/Rdatatable/data.table) repository* 36 | 37 | 1: To make it easier to count the characters per line you can edit your $HOME/.vimrc ($HOME/_vimrc on Windows) to include ":set ruler" which will display the line and position numbers in the bottom right corner of the terminal when editing the commit messages. 38 | -------------------------------------------------------------------------------- /R/plotting-annScatterGrob.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## annScatterGrob -- not yet exported 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @importFrom grDevices extendrange 6 | #' @import grid 7 | 8 | annScatterGrob <- function(x, y, ann = NULL, xlab = NULL, ylab = NULL, 9 | xscale = NULL, yscale = NULL, 10 | xaxis = TRUE, yaxis = TRUE, 11 | margins = c(5.1, 4.1, 4.1, 2.1), 12 | name = NULL, gp = NULL, vp = NULL, ...) { 13 | 14 | if (is.null(xscale)) xscale <- extendrange(range(x)) 15 | if (is.null(yscale)) yscale <- extendrange(range(y)) 16 | 17 | pltVp <- plotViewport(margins = margins, name = "annSctrPlotVp") 18 | datVp <- viewport(xscale = xscale, yscale = yscale, name = "annSctrDataVp") 19 | annSctrVp <- vpTree(pltVp, vpList(datVp)) 20 | annSctr <- makeAnnScatter(x = x, 21 | y = y, 22 | ann = ann, 23 | xaxs = xaxis, 24 | yaxs = yaxis, 25 | xlab = xlab, 26 | ylab = ylab, 27 | vp = annSctrVp, 28 | ...) 29 | gTree(name = name, 30 | ann = ann, 31 | xscale = xscale, 32 | yscale = yscale, 33 | vp = vp, 34 | childrenvp = annSctrVp, 35 | children = annSctr, 36 | cl = "annScatterGrob") 37 | 38 | } 39 | 40 | grid.annScatterGrob <- function(x, y, ann = NULL, xlab = NULL, ylab = NULL, 41 | xscale = NULL, yscale = NULL, 42 | xaxis = TRUE, yaxis = TRUE, 43 | margins = c(5.1, 4.1, 4.1, 2.1), 44 | name = NULL, gp = NULL, vp = NULL, ...) { 45 | 46 | g <- annScatterGrob(x = x, 47 | y = y, 48 | ann = ann, 49 | xlab = xlab, 50 | ylab = ylab, 51 | xaxis = xaxis, 52 | yaxis = yaxis, 53 | xscale = xscale, 54 | yscale = yscale, 55 | margins = margins, 56 | name = name, 57 | gp = gp, 58 | vp = vp, 59 | ...) 60 | grid.draw(g) 61 | 62 | } 63 | 64 | makeAnnScatter <- function(x, y, ann, xaxs, yaxs, xlab, ylab, vp, ...) { 65 | 66 | annLst <- vector(mode = "list", length = length(ann)) 67 | nms <- names(ann) 68 | if (is.null(nms)) nms <- sprintf("ann-%s", seq_along(ann)) 69 | for (i in seq_along(ann)) { 70 | ind <- ann[i] 71 | annLst[[i]] <- nullGrob(x = unit(x[ind], "native"), 72 | y = unit(y[ind], "native"), 73 | name = nms[i]) 74 | } 75 | grbLst <- gList() 76 | grbLst[['annotations']] <- gTree(name = "annotations", 77 | vp = vp, 78 | children = do.call("gList", annLst)) 79 | grbLst[['sctr']] <- pointsGrob(x = x, y = y, vp = vp, ...) 80 | if (xaxs) grbLst[['xaxs']] <- grid.xaxis(draw = FALSE, vp = vp) 81 | if (yaxs) grbLst[['yaxs']] <- grid.yaxis(draw = FALSE, vp = vp) 82 | if (!is.null(xlab)) { 83 | grbLst[['xlab']] <- textGrob(xlab, y = unit(-3, "line"), vp = vp) 84 | } 85 | if (!is.null(ylab)) { 86 | grbLst[['ylab']] <- textGrob(ylab, 87 | x = unit(-3, "line"), 88 | vp = vp, 89 | rot = 90) 90 | } 91 | 92 | grbLst 93 | 94 | } 95 | -------------------------------------------------------------------------------- /man/TxpSlice-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/allClasses.R, R/methods-TxpSlice.R 3 | \docType{class} 4 | \name{TxpSlice-class} 5 | \alias{TxpSlice-class} 6 | \alias{TxpSlice} 7 | \alias{txpValueNames,TxpSlice-method} 8 | \alias{txpValueNames<-,TxpSlice-method} 9 | \alias{txpTransFuncs,TxpSlice-method} 10 | \alias{txpTransFuncs<-,TxpSlice-method} 11 | \alias{length,TxpSlice-method} 12 | \alias{merge,TxpSlice,TxpSlice-method} 13 | \title{ToxPi Slice} 14 | \usage{ 15 | TxpSlice(txpValueNames, txpTransFuncs = NULL) 16 | 17 | \S4method{txpValueNames}{TxpSlice}(x) 18 | 19 | \S4method{txpValueNames}{TxpSlice}(x) <- value 20 | 21 | \S4method{txpTransFuncs}{TxpSlice}(x) 22 | 23 | \S4method{txpTransFuncs}{TxpSlice}(x) <- value 24 | 25 | \S4method{length}{TxpSlice}(x) 26 | 27 | \S4method{merge}{TxpSlice,TxpSlice}(x, y) 28 | } 29 | \arguments{ 30 | \item{txpValueNames}{Passed to \code{txpValueNames} slot} 31 | 32 | \item{txpTransFuncs}{Passed to \code{txpTransFuncs} slot} 33 | 34 | \item{x, y}{\code{TxpSlice} object} 35 | 36 | \item{value}{Replacement value} 37 | } 38 | \description{ 39 | S4 class to store ToxPi slices 40 | } 41 | \details{ 42 | If the user supplies \code{txpTransFuncs} a single function/\link{TxpTransFunc} object, 43 | the given function will be recycled for each input with a warning. 44 | } 45 | \section{Functions}{ 46 | \itemize{ 47 | \item \code{txpValueNames(TxpSlice)}: Return \code{txpValueNames} slot 48 | 49 | \item \code{txpTransFuncs(TxpSlice)}: Return \code{txpTransFuncs} slot 50 | 51 | \item \code{length(TxpSlice)}: Return number of inputs in slice; shortcut for 52 | \code{length(txpValueNames(x))} 53 | 54 | \item \code{merge(x = TxpSlice, y = TxpSlice)}: Merge two \code{TxpSlice} objects into a single 55 | slice 56 | 57 | }} 58 | \section{Slots}{ 59 | 60 | \describe{ 61 | \item{\code{txpValueNames}}{\verb{vector()} specifying the input columns to 62 | include in the slice} 63 | 64 | \item{\code{txpTransFuncs}}{\link{TxpTransFuncList} with one function per entry in 65 | \code{txpValueNames} or an object that can be coerced to \code{TxpTransFuncList}; 66 | when \code{NULL}, no transformation function applied} 67 | }} 68 | 69 | \examples{ 70 | ## Create TxpSlice object 71 | # Without transform functions 72 | TxpSlice(txpValueNames = c("sqrData", "expData")) 73 | # With transform functions 74 | TxpSlice(txpValueNames = c("sqrData", "expData"), 75 | txpTransFuncs = c(sq = function(x) x^2, log = function(x) log(x))) 76 | 77 | # Transformation function recycled with warning when single function given 78 | TxpSlice(txpValueNames = c("sqrData", "expData"), 79 | txpTransFuncs = function(x) x^2) 80 | 81 | 82 | ## Access TxpSlice slots 83 | sl <- TxpSlice(txpValueNames = c("sqrData", "expData"), 84 | txpTransFuncs = c(sq = function(x) x^2, 85 | log = function(x) log(x))) 86 | txpValueNames(sl) 87 | txpTransFuncs(sl) 88 | 89 | ## Replacement 90 | txpValueNames(sl)[1] <- "hello" 91 | sl 92 | 93 | txpTransFuncs(sl)[[2]](exp(1)) 94 | txpTransFuncs(sl)[[2]] <- function(x) sqrt(x) 95 | txpTransFuncs(sl)[[2]](exp(1)) 96 | 97 | # Note that replacing a single list element does NOT update the name 98 | sl 99 | names(txpTransFuncs(sl))[2] <- "sqrt" 100 | sl 101 | 102 | # Replacing the whole list DOES update the names 103 | txpTransFuncs(sl) <- list(sqrt = function(x) sqrt(x), 104 | log = function(x) log(x)) 105 | sl 106 | 107 | ## length -- returns number of inputs 108 | length(TxpSlice(letters)) 109 | 110 | ## merge 111 | s1 <- TxpSlice("hello") 112 | s2 <- TxpSlice("data") 113 | merge(s1, s2) 114 | 115 | # Note, input names still must be unique 116 | \dontrun{merge(s1, s1)} ## produces error 117 | } 118 | -------------------------------------------------------------------------------- /tests/testthat/guiFiles/gui_test_data.csv: -------------------------------------------------------------------------------- 1 | "# Slice1_1ab!2!0xf3622dff!linear(x)","","","","x","x","","" 2 | "# Slice1_1a!1!0xff7e4eff!linear(x)","","","","x","","","" 3 | "# Slice1_2ab!2!0xff9269ff!linear(x)","","","","","","x","x" 4 | "# Slice1_2a!1!0xffa27fff!linear(x)","","","","","","x","" 5 | "# Slice2_1ab!2!0xfba71bff!hit count","","","","x","x","","" 6 | "# Slice2_1a!1!0xffb73eff!hit count","","","","x","","","" 7 | "# Slice2_2ab!2!0xffc25bff!hit count","","","","","","x","x" 8 | "# Slice2_2a!1!0xffcb73ff!hit count","","","","","","x","" 9 | "# Slice3_1ab!2!0x57b757ff!-log10(x)","","","","x","x","","" 10 | "# Slice3_1a!1!0x70c970ff!-log10(x)","","","","x","","","" 11 | "# Slice3_2ab!2!0x8add8aff!-log10(x)","","","","","","x","x" 12 | "# Slice3_2a!1!0xa5f4a5ff!-log10(x)","","","","","","x","" 13 | "# Slice4_1ab!2!0x41a9c9ff!-log10(x)+log10(max(x))","","","","x","x","","" 14 | "# Slice4_1a!1!0x5ebfddff!-log10(x)+log10(max(x))","","","","x","","","" 15 | "# Slice4_2ab!2!0x7cd7f3ff!-log10(x)+log10(max(x))","","","","","","x","x" 16 | "# Slice4_2a!1!0x95e6ffff!-log10(x)+log10(max(x))","","","","","","x","" 17 | "# Slice5_1ab!2!0x4258c9ff!-log10(x)+6","","","","x","x","","" 18 | "# Slice5_1a!1!0x5f73ddff!-log10(x)+6","","","","x","","","" 19 | "# Slice5_2ab!2!0x7d90f3ff!-log10(x)+6","","","","","","x","x" 20 | "# Slice5_2a!1!0x96a6ffff!-log10(x)+6","","","","","","x","" 21 | "# Slice6_1ab!2!0x9a42c8ff!-ln(x)","","","","x","x","","" 22 | "# Slice6_1a!1!0xb15fdcff!-ln(x)","","","","x","","","" 23 | "# Slice6_2ab!2!0xca7df2ff!-ln(x)","","","","","","x","x" 24 | "# Slice6_2a!1!0xdc96ffff!-ln(x)","","","","","","x","" 25 | "# Slice7_1ab!2!0xc84164ff!log10(x)","","","","x","x","","" 26 | "# Slice7_1a!1!0xdc5e7eff!log10(x)","","","","x","","","" 27 | "# Slice7_2ab!2!0xf27c9aff!log10(x)","","","","","","x","x" 28 | "# Slice7_2a!1!0xff95b0ff!log10(x)","","","","","","x","" 29 | "# Slice8_1ab!2!0x888888ff!sqrt(x)","","","","x","x","","" 30 | "# Slice8_1a!1!0x969696ff!sqrt(x)","","","","x","","","" 31 | "# Slice8_2ab!2!0xa5a5a5ff!sqrt(x)","","","","","","x","x" 32 | "# Slice8_2a!1!0xb5b5b5ff!sqrt(x)","","","","","","x","" 33 | "# Slice9_1ab!2!0x4d8080ff!zscore(x)","","","","x","x","","" 34 | "# Slice9_1a!1!0x5d8d8dff!zscore(x)","","","","x","","","" 35 | "# Slice9_2ab!2!0x6e9b9bff!zscore(x)","","","","","","x","x" 36 | "# Slice9_2a!1!0x81aaaaff!zscore(x)","","","","","","x","" 37 | "# Slice10_1ab!2!0x804d80ff!uniform(x)","","","","x","x","","" 38 | "# Slice10_1a!1!0x8d5d8dff!uniform(x)","","","","x","","","" 39 | "# Slice10_2ab!2!0x9b6e9bff!uniform(x)","","","","","","x","x" 40 | "# Slice10_2a!1!0xaa81aaff!uniform(x)","","","","","","x","" 41 | "row","SID","CASRN","Name","y1a","y1b","y2a","y2b" 42 | "1","NA","NA","x01","0.0","0.0","7.0","7.0" 43 | "2","NA","NA","x02","0.0","2.0","7.0","11.0" 44 | "3","NA","NA","x03","0.0","3.0","7.0","13.0" 45 | "4","NA","NA","x04","0.0","-5.0","7.0","-17.0" 46 | "5","NA","NA","x05","0.0","NaN","7.0","NaN" 47 | "6","NA","NA","x06","2.0","0.0","11.0","7.0" 48 | "7","NA","NA","x07","2.0","2.0","11.0","11.0" 49 | "8","NA","NA","x08","2.0","3.0","11.0","13.0" 50 | "9","NA","NA","x09","2.0","-5.0","11.0","-17.0" 51 | "10","NA","NA","x10","2.0","NaN","11.0","NaN" 52 | "11","NA","NA","x11","3.0","0.0","13.0","7.0" 53 | "12","NA","NA","x12","3.0","2.0","13.0","11.0" 54 | "13","NA","NA","x13","3.0","3.0","13.0","13.0" 55 | "14","NA","NA","x14","3.0","-5.0","13.0","-17.0" 56 | "15","NA","NA","x15","3.0","NaN","13.0","NaN" 57 | "16","NA","NA","x16","-5.0","0.0","-17.0","7.0" 58 | "17","NA","NA","x17","-5.0","2.0","-17.0","11.0" 59 | "18","NA","NA","x18","-5.0","3.0","-17.0","13.0" 60 | "19","NA","NA","x19","-5.0","-5.0","-17.0","-17.0" 61 | "20","NA","NA","x20","-5.0","NaN","-17.0","NaN" 62 | "21","NA","NA","x21","NaN","0.0","NaN","7.0" 63 | "22","NA","NA","x22","NaN","2.0","NaN","11.0" 64 | "23","NA","NA","x23","NaN","3.0","NaN","13.0" 65 | "24","NA","NA","x24","NaN","-5.0","NaN","-17.0" 66 | "25","NA","NA","x25","NaN","NaN","NaN","NaN" 67 | -------------------------------------------------------------------------------- /R/methods-TxpTransFuncList.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## methods-txpTransFuncList 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name TxpTransFuncList-class 6 | #' @title List of TxpTransFunc objects 7 | #' @description Extension of [S4Vectors::SimpleList] that holds only `NULL` or 8 | #' [TxpTransFunc] objects. 9 | #' 10 | #' @param ... [TxpTransFunc] object or function to create `TxpTransFuncList` 11 | #' object 12 | #' @param x `list`, `function`, or [TxpTransFunc] object to coerce to 13 | #' `TxpTransFuncList` 14 | #' 15 | #' @details 16 | #' When `...` includes function objects, `TxpTransFuncList` will attempt to 17 | #' coerce them to [TxpTransFunc] and return an error if any of the elements 18 | #' cannot be coerced to [TxpTransFunc]. 19 | #' 20 | #' @examples 21 | #' ## Create TxpTransFunc objects 22 | #' tf1 <- TxpTransFunc(function(x) x) 23 | #' tf2 <- TxpTransFunc(function(x) sqrt(x)) 24 | #' 25 | #' ## Create TxpTransFuncList 26 | #' tfl <- TxpTransFuncList(linear = tf1, sqrt = tf2, cube = function(x) x^3) 27 | #' tfl[[3]](3) == 27 28 | #' tfl[["sqrt"]](4) == 2 29 | #' 30 | #' ## Concatenate 31 | #' c(tfl, tfl) 32 | #' 33 | #' ## names 34 | #' names(c(tfl, tfl)) 35 | #' 36 | #' # note: names are printed as '' when missing; NULL is printed when list item 37 | #' # is NULL 38 | #' names(TxpTransFuncList(function(x) x, NULL)) 39 | #' TxpTransFuncList(function(x) x, NULL) 40 | #' 41 | #' ## coercion 42 | #' as(function(x) x, "TxpTransFuncList") 43 | #' as.TxpTransFuncList(function(x) x) 44 | #' 45 | #' as(TxpTransFunc(function(x) x), "TxpTransFuncList") 46 | #' as.TxpTransFuncList(TxpTransFunc(function(x) x)) 47 | #' 48 | #' as(list(function(x) x, sqrt = function(x) sqrt(x)), "TxpTransFuncList") 49 | #' as.TxpTransFuncList(list(function(x) x, sqrt = function(x) sqrt(x))) 50 | 51 | NULL 52 | 53 | ##----------------------------------------------------------------------------## 54 | ## constructor 55 | 56 | .TxpTransFuncList.toTransFunc <- function(x) { 57 | if (!is.null(x) && !inherits(x, "TxpTransFunc")) { 58 | x <- try(TxpTransFunc(x), silent = TRUE) 59 | } 60 | x 61 | } 62 | 63 | #' @rdname TxpTransFuncList-class 64 | #' @export 65 | 66 | TxpTransFuncList <- function(...) { 67 | listData <- lapply(list(...), .TxpTransFuncList.toTransFunc) 68 | valid <- vapply(listData, is, logical(1), "TxpTransFunc_OR_NULL") 69 | if (any(!valid)) { 70 | stop("Some of the given list items could not be coerced to 'TxpTransFunc'.") 71 | } 72 | new2("TxpTransFuncList", listData) 73 | } 74 | 75 | ##----------------------------------------------------------------------------## 76 | ## validity 77 | 78 | .TxpTransFuncList.validity <- function(object) { 79 | msg <- NULL 80 | valid <- vapply(object@listData, is, logical(1), "TxpTransFunc_OR_NULL") 81 | if (any(!valid)) { 82 | msg <- c(msg, "All TxpFuncList objects must be of class 'TxpTransFunc.'") 83 | } 84 | if (is.null(msg)) return(TRUE) 85 | msg 86 | } 87 | 88 | setValidity2("TxpTransFuncList", .TxpTransFuncList.validity) 89 | 90 | ##----------------------------------------------------------------------------## 91 | ## show 92 | 93 | .TxpTransFuncList.show <- function(object) { 94 | lnms <- .listDisplayNames(object) 95 | .coolcat(" TxpTransFuncList of length %d: %s\n", lnms) 96 | } 97 | 98 | setMethod("show", "TxpTransFuncList", .TxpTransFuncList.show) 99 | 100 | ##----------------------------------------------------------------------------## 101 | ## coercion 102 | 103 | .TxpTransFuncList.from.list <- function(from) { 104 | do.call("TxpTransFuncList", from) 105 | } 106 | 107 | setAs("list", "TxpTransFuncList", .TxpTransFuncList.from.list) 108 | 109 | .TxpTransFuncList.from.func <- function(from) { 110 | TxpTransFuncList(from) 111 | } 112 | 113 | setAs("function", "TxpTransFuncList", .TxpTransFuncList.from.func) 114 | 115 | #' @rdname TxpTransFuncList-class 116 | #' @export 117 | 118 | as.TxpTransFuncList <- function(x) as(x, "TxpTransFuncList") 119 | 120 | ##----------------------------------------------------------------------------## 121 | 122 | -------------------------------------------------------------------------------- /man/TxpModel-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/allClasses.R, R/methods-TxpModel.R 3 | \docType{class} 4 | \name{TxpModel-class} 5 | \alias{TxpModel-class} 6 | \alias{TxpModel} 7 | \alias{txpSlices,TxpModel-method} 8 | \alias{TxpModel-txpSlices} 9 | \alias{txpSlices<-,TxpModel-method} 10 | \alias{txpWeights,TxpModel-method} 11 | \alias{txpWeights<-,TxpModel-method} 12 | \alias{txpTransFuncs,TxpModel-method} 13 | \alias{txpTransFuncs<-,TxpModel-method} 14 | \alias{txpValueNames,TxpModel-method} 15 | \alias{names,TxpModel-method} 16 | \alias{names<-,TxpModel-method} 17 | \alias{length,TxpModel-method} 18 | \alias{merge,TxpModel,TxpModel-method} 19 | \title{ToxPi Model} 20 | \usage{ 21 | TxpModel(txpSlices, txpWeights = NULL, txpTransFuncs = NULL) 22 | 23 | \S4method{txpSlices}{TxpModel}(x) 24 | 25 | \S4method{txpSlices}{TxpModel}(x) <- value 26 | 27 | \S4method{txpWeights}{TxpModel}(x, adjusted = FALSE) 28 | 29 | \S4method{txpWeights}{TxpModel}(x) <- value 30 | 31 | \S4method{txpTransFuncs}{TxpModel}(x) 32 | 33 | \S4method{txpTransFuncs}{TxpModel}(x) <- value 34 | 35 | \S4method{txpValueNames}{TxpModel}(x, simplify = FALSE) 36 | 37 | \S4method{names}{TxpModel}(x) 38 | 39 | \S4method{names}{TxpModel}(x) <- value 40 | 41 | \S4method{length}{TxpModel}(x) 42 | 43 | \S4method{merge}{TxpModel,TxpModel}(x, y) 44 | } 45 | \arguments{ 46 | \item{txpSlices}{Passed to \code{txpSlices} slot} 47 | 48 | \item{txpWeights}{Passed to \code{txpWeights} slot} 49 | 50 | \item{txpTransFuncs}{Passed to \code{txpTransFuncs} slot} 51 | 52 | \item{x, y}{TxpModel object} 53 | 54 | \item{value}{Replacement value} 55 | 56 | \item{adjusted}{Scalar logical, should the returned weights be adjusted 57 | such that they sum to 1?} 58 | 59 | \item{simplify}{Scalar logical, when \code{TRUE} the returned \code{list} is simplified} 60 | } 61 | \description{ 62 | S4 class to store ToxPi models 63 | } 64 | \section{Functions}{ 65 | \itemize{ 66 | \item \code{txpSlices(TxpModel)}: Return \code{txpSlices} slot 67 | 68 | \item \code{txpWeights(TxpModel)}: Return \code{txpWeights} slot 69 | 70 | \item \code{txpTransFuncs(TxpModel)}: Return \code{txpTransFuncs} slot 71 | 72 | \item \code{txpValueNames(TxpModel)}: Return \code{list} of \code{txpValueNames} slots for the 73 | contained \link{TxpSliceList} object, or \code{vector} when \code{simplify = TRUE} 74 | 75 | \item \code{names(TxpModel)}: Return slice names; shortcut for 76 | \code{names(txpSlices(x))} 77 | 78 | \item \code{length(TxpModel)}: Return number of slices in model; shortcut for 79 | \code{length(txpSlices(x))} 80 | 81 | \item \code{merge(x = TxpModel, y = TxpModel)}: Merge two \code{TxpModel} objects into a single 82 | model 83 | 84 | }} 85 | \section{Slots}{ 86 | 87 | \describe{ 88 | \item{\code{txpSlices}}{\link{TxpSliceList} object} 89 | 90 | \item{\code{txpWeights}}{numeric vector specifying the relative weight of each slice; 91 | when NULL, defaults to 1 (equal weighting) for each slice} 92 | 93 | \item{\code{txpTransFuncs}}{\link{TxpTransFuncList} object (or list of functions 94 | coercible to TxpTransFuncList)} 95 | }} 96 | 97 | \examples{ 98 | ## Create TxpSliceList & TxpTransFuncList objects 99 | s1 <- list(S1 = TxpSlice("inpt1"), S2 = TxpSlice("inpt2")) 100 | tf <- list(NULL, sqrt = function(x) sqrt(x)) 101 | 102 | ## Create TxpModel object 103 | m1 <- TxpModel(txpSlices = s1, txpWeights = 2:1, txpTransFuncs = tf) 104 | m1 105 | 106 | ## Access TxpModel slots 107 | txpSlices(m1) 108 | txpWeights(m1) 109 | txpWeights(m1, adjusted = TRUE) 110 | txpTransFuncs(m1) 111 | 112 | ## length 113 | length(m1) ## equal to length(txpSlices(m1)) 114 | length(m1) == length(txpSlices(m1)) 115 | 116 | ## names 117 | names(m1) ## equal to names(txpSlices(m1)) 118 | all(names(m1) == names(txpSlices(m1))) 119 | 120 | ## Replacement 121 | m2 <- m1 122 | txpSlices(m2) <- list(S3 = TxpSlice("inpt3"), S4 = TxpSlice("inpt4")) 123 | m2 124 | names(m2)[2] <- "hello" 125 | names(m2) 126 | txpTransFuncs(m2) <- NULL 127 | m2 128 | txpTransFuncs(m2)[[1]] <- function(x) x^2 129 | names(txpTransFuncs(m2))[1] <- "sq" 130 | m2 131 | 132 | ## merge 133 | m3 <- merge(m1, m2) 134 | m3 135 | } 136 | -------------------------------------------------------------------------------- /R/txpCalculateScores.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## txpCalculateScores 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name txpCalculateScores 6 | #' @title Calculate ToxPi Scores for the given model and input data 7 | #' @description Calculate ToxPi Scores for the given model and input data 8 | #' 9 | #' @param model [TxpModel] object or [TxpModelList] object 10 | #' @param input data.frame object containing the model input data 11 | #' @param id.var Character scalar, column in 'input' to store in 12 | #' @inheritParams TxpResultParam-class 13 | #' @inheritParams txpGenerics 14 | #' 15 | #' @details 16 | #' `txpCalculateScores` is implemented as an S4 generic function with methods 17 | #' for [TxpModel] and [TxpModelList]. 18 | #' 19 | #' Ranks are calculated such that the highest ToxPi score has a rank of 1. 20 | #' 21 | #' Missingness is determined after applying input-level transformations but 22 | #' before applying slice-level transformations. 23 | #' 24 | #' @seealso [TxpModel], [TxpResult], [TxpResultParam] 25 | #' 26 | #' @template roxgn-loadExamples 27 | #' @template roxgn-calcTxpModel 28 | #' @template roxgn-calcTxpModelList 29 | #' 30 | #' @return [TxpResult] or [TxpResultList] object 31 | #' 32 | #' @export 33 | 34 | NULL 35 | 36 | .sumNA <- function(x) { 37 | if (all(is.na(x))) return(NA_real_) 38 | sum(x, na.rm = TRUE) 39 | } 40 | 41 | .z2o <- function(x) { 42 | (x - min(x, na.rm = TRUE))/diff(range(x, na.rm = TRUE)) 43 | } 44 | 45 | .sumSlice <- function(slice, input, negative.value.handling) { 46 | # Applies input-level transformation functions and sums the values to give 47 | # a raw slice score 48 | nms <- txpValueNames(slice) 49 | dat <- input[nms] 50 | if (negative.value.handling == "missing") dat[dat < 0] <- NA 51 | tfs <- txpTransFuncs(slice) 52 | for (i in seq_along(nms)) { 53 | if (is.null(tfs[[i]])) next 54 | dat[[i]] <- tfs[[i]](dat[[i]]) 55 | } 56 | x <- apply(dat, MARGIN = 1, .sumNA) 57 | dat <- unlist(dat) 58 | y <- sum(!is.finite(dat)) / length(dat) 59 | list(sum = x, mis = y) 60 | } 61 | 62 | .calculateScores <- function(model, input, 63 | id.var = NULL, 64 | rank.ties.method = c("average", "first", "last", 65 | "random", "max", "min"), 66 | negative.value.handling = c("keep", "missing")) { 67 | 68 | ## Test inputs 69 | .chkModelInput(model = model, input = input) 70 | param <- TxpResultParam(rank.ties.method = rank.ties.method, 71 | negative.value.handling = negative.value.handling) 72 | 73 | ## Clean up infinite in input 74 | input <- .rmInfinite(model = model, input = input) 75 | 76 | ## Calculate raw slice scores and missingness 77 | x <- lapply( 78 | txpSlices(model), .sumSlice, input = input, 79 | negative.value.handling = slot(param, "negative.value.handling")) 80 | slc <- sapply(x, "[[", "sum") 81 | mis <- sapply(x, "[[", "mis") 82 | 83 | ## Look for and apply slice-level transformation functions 84 | tfs <- txpTransFuncs(model) 85 | if (any(!sapply(tfs, is.null))) { 86 | for (i in 1:ncol(slc)) { 87 | if (is.null(tfs[[i]])) next 88 | slc[ , i] <- tfs[[i]](slc[ , i]) 89 | } 90 | } 91 | 92 | ## Make infinite NaN 93 | slc[is.infinite(slc)] <- NaN 94 | 95 | ## Scale slice scores from 0 to 1 96 | slc <- apply(slc, 2, .z2o) 97 | 98 | ## Make NA 0 99 | slc[is.na(slc)] <- 0 100 | 101 | ## Calculate ToxPi score 102 | wts <- txpWeights(model, adjusted = TRUE) 103 | score <- rowSums(slc*rep(wts, each = NROW(slc)), na.rm = TRUE) 104 | 105 | ## Calculate ToxPi ranks 106 | rnks <- rank(-score, ties.method = rank.ties.method) 107 | 108 | ## Assign IDs 109 | ids <- if (!is.null(id.var)) as.character(input[[id.var]]) else NULL 110 | 111 | TxpResult(txpScores = score, 112 | txpSliceScores = slc, 113 | txpRanks = rnks, 114 | txpMissing = mis, 115 | txpModel = model, 116 | txpIDs = ids, 117 | txpResultParam = param) 118 | 119 | } 120 | 121 | ##----------------------------------------------------------------------------## 122 | 123 | -------------------------------------------------------------------------------- /R/allClasses.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## All classes 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @import methods 6 | #' @importFrom S4Vectors setValidity2 new2 7 | #' @importClassesFrom S4Vectors character_OR_NULL 8 | 9 | NULL 10 | 11 | ##----------------------------------------------------------------------------## 12 | ## Virtual classes 13 | 14 | #' @importClassesFrom S4Vectors SimpleList 15 | #' @importClassesFrom S4Vectors List 16 | #' @importFrom S4Vectors List 17 | 18 | setClass("NamedList", contains = c("VIRTUAL", "SimpleList")) 19 | 20 | ##----------------------------------------------------------------------------## 21 | ## TxpTransFunc 22 | 23 | #' @rdname TxpTransFunc-class 24 | #' @exportClass TxpTransFunc 25 | 26 | setClass("TxpTransFunc", contains = "function", prototype = function(x) x) 27 | 28 | setClassUnion("TxpTransFunc_OR_NULL", members = c("TxpTransFunc", "NULL")) 29 | 30 | ##----------------------------------------------------------------------------## 31 | ## TxpTransFuncList 32 | 33 | #' @rdname TxpTransFuncList-class 34 | #' @exportClass TxpTransFuncList 35 | 36 | setClass("TxpTransFuncList", 37 | contains = "SimpleList", 38 | prototype = prototype(elementType = "TxpTransFunc_OR_NULL")) 39 | 40 | ##----------------------------------------------------------------------------## 41 | ## TxpSlice 42 | 43 | #' @rdname TxpSlice-class 44 | #' @exportClass TxpSlice 45 | 46 | setClass("TxpSlice", 47 | slots = c(txpValueNames = "character", 48 | txpTransFuncs = "TxpTransFuncList")) 49 | 50 | setClassUnion("TxpSlice_OR_NULL", members = c("TxpSlice", "NULL")) 51 | 52 | ##----------------------------------------------------------------------------## 53 | ## TxpSliceList 54 | 55 | #' @rdname TxpSliceList-class 56 | #' @importClassesFrom S4Vectors SimpleList 57 | #' @exportClass TxpSliceList 58 | 59 | setClass("TxpSliceList", 60 | contains = "NamedList", 61 | prototype = prototype(elementType = "TxpSlice")) 62 | 63 | ##----------------------------------------------------------------------------## 64 | ## TxpModel 65 | 66 | #' @rdname TxpModel-class 67 | #' @exportClass TxpModel 68 | 69 | setClass("TxpModel", 70 | slots = c(txpSlices = "TxpSliceList", 71 | txpWeights = "numeric", 72 | txpTransFuncs = "TxpTransFuncList")) 73 | 74 | setClassUnion("TxpModel_OR_NULL", members = c("TxpModel", "NULL")) 75 | 76 | ##----------------------------------------------------------------------------## 77 | ## TxpModelList 78 | 79 | #' @rdname TxpModelList-class 80 | #' @importClassesFrom S4Vectors SimpleList 81 | #' @exportClass TxpModelList 82 | 83 | setClass("TxpModelList", 84 | contains = "SimpleList", 85 | prototype = prototype(elementType = "TxpModel")) 86 | 87 | ##----------------------------------------------------------------------------## 88 | ## TxpResultParam 89 | 90 | #' @name TxpResultParam-class 91 | #' @exportClass TxpResultParam 92 | 93 | setClass("TxpResultParam", 94 | slots = c(rank.ties.method = "character", 95 | negative.value.handling = "character")) 96 | 97 | ##----------------------------------------------------------------------------## 98 | ## TxpResult 99 | 100 | #' @name TxpResult-class 101 | #' @exportClass TxpResult 102 | 103 | setClass("TxpResult", 104 | slots = c(txpScores = "numeric", 105 | txpSliceScores = "matrix", 106 | txpRanks = "numeric", 107 | txpMissing = "numeric", 108 | txpModel = "TxpModel", 109 | txpIDs = "character_OR_NULL", 110 | txpResultParam = "TxpResultParam")) 111 | 112 | setClassUnion("TxpResult_OR_NULL", members = c("TxpResult", "NULL")) 113 | 114 | ##----------------------------------------------------------------------------## 115 | ## TxpResultList 116 | 117 | #' @rdname TxpResultList-class 118 | #' @importClassesFrom S4Vectors SimpleList 119 | #' @exportClass TxpResultList 120 | 121 | setClass("TxpResultList", 122 | contains = "SimpleList", 123 | prototype = prototype(elementType = "TxpResult")) 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | -------------------------------------------------------------------------------- /R/methods-TxpSliceList.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## methods-txpSliceList 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name TxpSliceList-class 6 | #' @title List of TxpSlice objects 7 | #' @description Extension of [S4Vectors::SimpleList] that requires 8 | #' uniquely-named elements and holds only [TxpSlice] objects. 9 | #' 10 | #' @param ... [TxpSlice] object to create `TxpSliceList` object; MUST give 11 | #' unique names to each slice 12 | #' @param x `TxpSliceList` object 13 | #' @param simplify Scalar logical, when `TRUE` the returned `list` is simplified 14 | #' to a `vector`/[TxpTransFuncList] object 15 | #' 16 | #' @details 17 | #' Note, there is no coercion for [TxpSlice] to `TxpSliceList` because unique 18 | #' names are required. 19 | #' 20 | #' @examples 21 | #' ## Create TxpSlice objects 22 | #' s1 <- TxpSlice("input1", list(linear = function(x) x)) 23 | #' s2 <- TxpSlice(c("input2", "input3"), 24 | #' list(log = function(x) log(x), sqrt = function(x) sqrt(x))) 25 | #' 26 | #' ## Create TxpSliceList 27 | #' sl <- TxpSliceList(s1 = s1, s2 = s2) 28 | #' 29 | #' ## Accessors 30 | #' txpValueNames(sl) 31 | #' txpValueNames(sl, simplify = TRUE) 32 | #' 33 | #' txpTransFuncs(sl) 34 | #' txpTransFuncs(sl, simplify = TRUE) 35 | #' 36 | #' ## Coercion 37 | #' as(list(s1 = TxpSlice("hello"), s2 = TxpSlice("user")), "TxpSliceList") 38 | #' as.TxpSliceList(c(s1 = TxpSlice("hello"), s2 = TxpSlice("user"))) 39 | #' 40 | #' ## Concatenation 41 | #' c(sl, TxpSliceList(s3 = TxpSlice("input4"))) 42 | #' 43 | #' ## Reduce TxpSliceList to single slice 44 | #' Reduce(merge, sl) 45 | 46 | NULL 47 | 48 | ##----------------------------------------------------------------------------## 49 | ## constructor 50 | 51 | #' @rdname TxpSliceList-class 52 | #' @export 53 | 54 | TxpSliceList <- function(...) { 55 | listData <- list(...) 56 | new2("TxpSliceList", listData) 57 | } 58 | 59 | ##----------------------------------------------------------------------------## 60 | ## validity 61 | 62 | .TxpSliceList.validity <- function(object) { 63 | msg <- NULL 64 | valid <- vapply(object@listData, is, logical(1), "TxpSlice") 65 | if (any(!valid)) { 66 | msg <- c(msg, "All TxpSlice objects must be of class 'TxpSlice.'") 67 | } 68 | if (is.null(msg)) return(TRUE) 69 | msg 70 | } 71 | 72 | setValidity2("TxpSliceList", .TxpSliceList.validity) 73 | 74 | ##----------------------------------------------------------------------------## 75 | ## accessors 76 | 77 | #' @describeIn TxpSliceList-class Return `list` of `txpValueNames` slots for the 78 | #' contained [TxpSlice] objects, or `vector` when `simplify = TRUE` 79 | #' @importFrom rlang is_scalar_logical 80 | #' @export 81 | 82 | setMethod("txpValueNames", "TxpSliceList", function(x, simplify = FALSE) { 83 | stopifnot(is_scalar_logical(simplify)) 84 | nms <- lapply(x, txpValueNames) 85 | if (simplify) nms <- unlist(nms) 86 | nms 87 | }) 88 | 89 | #' @describeIn TxpSliceList-class Return `list` of `txpTransFuncs` slots for the 90 | #' contained [TxpSlice] objects, or [TxpTransFuncList] when `simplify = TRUE` 91 | #' @importFrom rlang is_scalar_logical 92 | #' @export 93 | 94 | setMethod("txpTransFuncs", "TxpSliceList", function(x, simplify = FALSE) { 95 | stopifnot(is_scalar_logical(simplify)) 96 | fxs <- lapply(x, txpTransFuncs) 97 | if (simplify) fxs <- Reduce(c, fxs) 98 | fxs 99 | }) 100 | 101 | ##----------------------------------------------------------------------------## 102 | ## duplicated 103 | 104 | #' @describeIn TxpSliceList-class Returns logical vector of `length(x)`, where 105 | #' `TRUE` indicates a duplicate slice in the list; see [base::duplicated] 106 | #' @export 107 | 108 | setMethod("duplicated", "TxpSliceList", function(x) .dupList(x)) 109 | 110 | ##----------------------------------------------------------------------------## 111 | ## coercion 112 | 113 | .TxpSliceList.from.list <- function(from) { 114 | do.call("TxpSliceList", from) 115 | } 116 | 117 | setAs("list", "TxpSliceList", .TxpSliceList.from.list) 118 | 119 | #' @rdname TxpSliceList-class 120 | #' @export 121 | 122 | as.TxpSliceList <- function(x) as(x, "TxpSliceList") 123 | 124 | ##----------------------------------------------------------------------------## 125 | 126 | -------------------------------------------------------------------------------- /R/methods-TxpTransFunc.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## methods-TxpTransFunc 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name TxpTransFunc-class 6 | #' @title Numeric transformation function 7 | #' @description S4 class to store numeric transformation functions 8 | #' 9 | #' @param x function, see details 10 | #' 11 | #' @details 12 | #' \code{TxpTransFunc} inherits from a standard R function, but specifies a 13 | #' single input and a numeric output of the same length. 14 | #' 15 | #' Functions can be passed directly to \code{TxpTransFuncList} list and the 16 | #' functions will be coerced to \code{TxpTransFunc}. 17 | #' 18 | #' We have an imperfect system for dealing with primitive functions (e.g., 19 | #' [base::sqrt]). 20 | #' To coerce primitives to TxpTransFunc's, we wrap them in another function 21 | #' cal; wrapping the primitives obscures the original function and requires 22 | #' the user to explore the function environment to understand the primitive 23 | #' called. 24 | #' We recommend wrapping primitives in separate functions to make the intent 25 | #' clear, .e.g., `mysqrt <- function(x) sqrt(x)`. 26 | #' 27 | #' @examples 28 | #' f1 <- function(x) "hello" 29 | #' f2 <- function(x) 3 30 | #' f3 <- function(x) x + 5 31 | #' \dontrun{ 32 | #' t1 <- TxpTransFunc(x = f1) ## Produces error 33 | #' t2 <- TxpTransFunc(x = f2) ## Produces error 34 | #' } 35 | #' t3 <- TxpTransFunc(x = f3) 36 | #' 37 | #' ## TxpTransFunc objects act as any other function 38 | #' body(t3) 39 | #' formals(t3) 40 | #' t3(1:10) 41 | #' 42 | #' ## Coercion from functions 43 | #' \dontrun{ 44 | #' TxpTransFuncList(f1, f2, f3) ## Produces error because f1, f3 not valid 45 | #' } 46 | 47 | NULL 48 | 49 | ##----------------------------------------------------------------------------## 50 | ## constructor 51 | 52 | #' @rdname TxpTransFunc-class 53 | #' @export 54 | 55 | TxpTransFunc <- function(x) { 56 | if (missing(x)) return(new("TxpTransFunc")) 57 | if (is.primitive(x)) { 58 | somePrimitive <- x 59 | f <- .convertPrimitive(somePrimitive) 60 | } 61 | else f <- x 62 | new2("TxpTransFunc", f) 63 | } 64 | 65 | ##----------------------------------------------------------------------------## 66 | ## validity 67 | 68 | .TxpTransFunc.validity <- function(object) { 69 | msg <- NULL 70 | suppressWarnings({ 71 | res1 <- try(object(1:5), silent = TRUE) 72 | res2 <- try(object(1:6), silent = TRUE) 73 | }) 74 | if (is(res1, "try-error") || is(res2, "try-error")) { 75 | msg <- c(msg, "TxpTransFunc returned error when given numeric input.") 76 | return(msg) 77 | } 78 | if (length(res1) != 5 || length(res2) != 6) { 79 | msg <- c(msg, "TxpTransFunc output length must equal input length.") 80 | } 81 | if (!class(res1) %in% c("numeric", "integer")) { 82 | msg <- c(msg, "TxpTransFunc output must be numeric for numeric inputs.") 83 | } 84 | if (is.null(msg)) return(TRUE) 85 | msg 86 | } 87 | 88 | setValidity2(Class = "TxpTransFunc", method = .TxpTransFunc.validity) 89 | 90 | ##----------------------------------------------------------------------------## 91 | ## coercion 92 | 93 | .TxpTransFunc.coerce.from.function <- function(from) { 94 | if (is.primitive(from)) { 95 | somePrimitive <- from 96 | f <- .convertPrimitive(somePrimitive) 97 | } 98 | else f <- from 99 | TxpTransFunc(f) 100 | } 101 | 102 | setAs("function", "TxpTransFunc", .TxpTransFunc.coerce.from.function) 103 | 104 | ##----------------------------------------------------------------------------## 105 | ## concatenation 106 | 107 | ## Close, but rearranges the elements inappropriately: 108 | # f <- TxpTransFunc(f) 109 | # c(a = f, b = f, f) 110 | ## ALSO, causes errors with the 'c' method for TxpTransFuncList that would 111 | ## need correction 112 | # .TxpTransFunc.concatenate <- function(x, ...) { 113 | # lst <- if (missing(x)) list(...) else list(x, ...) 114 | # do.call("TxpTransFuncList", lst) 115 | # } 116 | # setMethod("c", "TxpTransFunc", .TxpTransFunc.concatenate) 117 | 118 | ##----------------------------------------------------------------------------## 119 | ## utilities 120 | .convertPrimitive <- function(somePrimitive) { 121 | warning("Using primitive functions obscures behavior; ", 122 | "see ?TxpTransFunc for more details.") 123 | f <- function(y) somePrimitive(y) 124 | f <- .make_function(formals(f), .substitute_q(body(f), environment(f))) 125 | } 126 | 127 | ##----------------------------------------------------------------------------## 128 | 129 | -------------------------------------------------------------------------------- /man/TxpResult-plot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/methods-TxpResult-plot.R 3 | \name{TxpResult-plot} 4 | \alias{TxpResult-plot} 5 | \alias{plot} 6 | \alias{plot,TxpResult,missing-method} 7 | \alias{plot,TxpResult,numeric-method} 8 | \title{Plot TxpResult objects} 9 | \usage{ 10 | \S4method{plot}{TxpResult,missing}( 11 | x, 12 | package = c("grid", "ggplot2"), 13 | fills = NULL, 14 | showScore = TRUE, 15 | gp = NULL, 16 | vp = NULL, 17 | name = NULL, 18 | newpage = TRUE, 19 | ..., 20 | ncol = NULL, 21 | bgColor = "grey80", 22 | borderColor = "white", 23 | sliceBorderColor = "white", 24 | sliceValueColor = NULL, 25 | sliceLineColor = NULL, 26 | showMissing = TRUE, 27 | showCenter = TRUE 28 | ) 29 | 30 | \S4method{plot}{TxpResult,numeric}( 31 | x, 32 | y, 33 | labels = NULL, 34 | newpage = TRUE, 35 | margins = c(4, 0, 1, 1), 36 | name = NULL, 37 | gp = NULL, 38 | vp = NULL, 39 | ... 40 | ) 41 | } 42 | \arguments{ 43 | \item{x}{\link{TxpResult} object} 44 | 45 | \item{package}{Character scalar, choice of "grid" or "ggplot2" for plotting 46 | ToxPi profiles} 47 | 48 | \item{fills}{Vector of colors to fill slices. Set to NULL to use default} 49 | 50 | \item{showScore}{Logical scalar, overall score printed below the name when 51 | \code{TRUE}} 52 | 53 | \item{gp, vp, name}{Passed to \link[grid:grid.frame]{grid::frameGrob} when creating the plotting 54 | area} 55 | 56 | \item{newpage}{Logical scalar, \link[grid:grid.newpage]{grid::grid.newpage} called prior to plotting 57 | when \code{TRUE}} 58 | 59 | \item{...}{Passed to \link{pieGridGrob} when plotting ToxPi and to pointsGrob 60 | when plotting ranks} 61 | 62 | \item{ncol}{Number of columns for ggplot2 ToxPi profiles} 63 | 64 | \item{bgColor, borderColor, sliceBorderColor, sliceValueColor, sliceLineColor}{Various color options when creating ggplot2 ToxPi profiles. Set to NULL 65 | for no color} 66 | 67 | \item{showMissing}{Boolean for coloring data missingness in ggplot2 68 | ToxPi profiles} 69 | 70 | \item{showCenter}{Boolean for showing inner circle in ggplot2 ToxPi 71 | profiles. When set to False overrides showMissing} 72 | 73 | \item{y}{Rank vector, i.e. \code{txpRanks(x)}} 74 | 75 | \item{labels}{Integer vector, indices of \code{x} to label in the rank plot} 76 | 77 | \item{margins}{Passed to \link[grid:plotViewport]{grid::plotViewport}; only affects the scatterplot 78 | region margins} 79 | } 80 | \value{ 81 | No return value when using grid; called for side effect (i.e. 82 | drawing in current graphics device). Will return ggplot2 object otherwise. 83 | } 84 | \description{ 85 | Plot \link{TxpResult} objects 86 | } 87 | \details{ 88 | It is strongly recommended to use a specific device (e.g., \link[grDevices:png]{grDevices::png}, 89 | \link[grDevices:pdf]{grDevices::pdf}) when creating rank plots. 90 | Using a GUI device will likely lead to inaccurate labeling, and any changes 91 | to the device size WILL lead to inaccurate labeling. 92 | 93 | The plotting is built on the \link[grid:grid-package]{grid::grid-package}, and can be adjusted or 94 | edited as such. 95 | 96 | If the labels are running of the device, the top or bottom margins can be 97 | increased with the \code{margins} parameter. 98 | 99 | ToxPi profiles can also be plotted using the ggplot2 package. 100 | } 101 | \section{Functions}{ 102 | \itemize{ 103 | \item \code{plot(x = TxpResult, y = missing)}: Plot ToxPi diagrams 104 | 105 | \item \code{plot(x = TxpResult, y = numeric)}: Plot ToxPi ranks 106 | 107 | }} 108 | \examples{ 109 | ## Load example dataset & model; see ?TxpModel for building model objects 110 | data(txp_example_input, package = "toxpiR") 111 | data(txp_example_model, package = "toxpiR") 112 | 113 | ## Calculate scores for single model; returns TxpResult object 114 | res <- txpCalculateScores(model = txp_example_model, 115 | input = txp_example_input, 116 | id.var = "name") 117 | 118 | library(grid) 119 | plot(res) 120 | plot(res[order(txpRanks(res))[1:4]]) 121 | 122 | library(ggplot2) 123 | plot(res, package = "gg") 124 | plot(res[order(txpRanks(res))], package = "gg", ncol = 5) + 125 | theme(legend.position = "bottom") 126 | 127 | plot(res, txpRanks(res)) 128 | plot(res, txpRanks(res), pch = 16, size = unit(0.75, "char")) 129 | 130 | ## Will likely make inaccurate labels within a GUI, e.g. RStudio 131 | ## use png, pdf, etc. to get accurate labels 132 | \dontrun{ 133 | tmpPdf <- tempfile() 134 | pdf(tmpPdf) 135 | plot(res, txpRanks(res), labels = c(10, 4, 2), pch = 16) 136 | dev.off() 137 | } 138 | 139 | } 140 | -------------------------------------------------------------------------------- /R/plotting-pieGrob.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## pieGrob 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name pieGrob 6 | #' @title Create a pie grob 7 | #' @description Create a pie grob 8 | #' @param rads Numeric, radius values for each slice from 0 to 1 9 | #' @param fills Colors to fill the slices 10 | #' @param wts Numeric, the relative portion of each slice 11 | #' @param name,vp,gp Passed to [grid::gTree] 12 | #' 13 | #' @details 14 | #' The default coloring can be set with `options("txp.fills")`. 15 | #' 16 | #' 17 | #' @examples 18 | #' library(grid) 19 | #' 20 | #' s <- seq(0.2, 1, by = 0.1) 21 | #' grid.newpage() 22 | #' grid.pieGrob(rads = s) 23 | #' grid.newpage() 24 | #' grid.pieGrob(rads = s, wts = s) 25 | #' 26 | #' curr_txp_fills <- options()$txp.fills 27 | #' options(txp.fills = 1:8) 28 | #' grid.newpage() 29 | #' grid.pieGrob(rads = s) 30 | #' options(txp.fills = curr_txp_fills) 31 | #' 32 | #' ## Can edit 33 | #' grid.newpage() 34 | #' grid.pieGrob(rads = s, name = "myPie") 35 | #' grid.ls() ## show the grid elements 36 | #' grid.edit("myPie", fills = 1:9, wts = 9:1) 37 | #' 38 | #' @return `pieGrob` [grid::grob] object 39 | #' 40 | #' @import grid 41 | #' @export 42 | 43 | pieGrob <- function(rads, fills = NULL, wts = NULL, 44 | name = NULL, vp = NULL, gp = NULL) { 45 | pieVp <- makePieViewport() 46 | gTree(name = name, 47 | rads = rads, 48 | fills = fills, 49 | wts = wts, 50 | gp = gp, 51 | vp = vp, 52 | childrenvp = pieVp, 53 | children = makePieGrob(rads = rads, 54 | fills = fills, 55 | wts = wts, 56 | vp = pieVp), 57 | cl = "pieGrob") 58 | } 59 | 60 | #' @rdname pieGrob 61 | #' @export 62 | 63 | grid.pieGrob <- function(rads, fills = NULL, wts = NULL, 64 | name = NULL, vp = NULL, gp = NULL) { 65 | g <- pieGrob(rads = rads, 66 | fills = fills, 67 | wts = wts, 68 | name = name, 69 | vp = vp, 70 | gp = gp) 71 | grid.draw(g) 72 | } 73 | 74 | #' @export 75 | 76 | editDetails.pieGrob <- function(x, specs) { 77 | if (any(c("rads", "fills", "wts") %in% names(specs))) { 78 | newRads <- if (is.null(specs$rads)) x$rads else specs$rads 79 | newFills <- if (is.null(specs$fills)) x$fills else specs$fills 80 | newWts <- if (is.null(specs$wts)) x$wts else specs$wts 81 | x <- setChildren(x, 82 | makePieGrob(rads = newRads, 83 | fills = newFills, 84 | wts = newWts, 85 | vp = x$childrenvp)) 86 | } 87 | x 88 | } 89 | 90 | makeSliceGrob <- function(rad, th0, th1, fill, name = NULL, vp = NULL) { 91 | th <- c(seq(th0, th1, by = pi/360), th1) 92 | x <- c(0, cos(th))*rad 93 | y <- c(0, sin(th))*rad 94 | polygonGrob(x = x, 95 | y = y, 96 | name = name, 97 | gp = gpar(fill = fill, col = NA), 98 | default.units = "native", 99 | vp = vp) 100 | } 101 | 102 | makePieGrob <- function(rads, fills = NULL, wts = NULL, vp = NULL) { 103 | nSlices <- length(rads) 104 | if (is.null(wts)) wts <- rep(1, nSlices) 105 | wts <- wts/sum(wts) 106 | ths <- cumsum(c(0, 2*pi*wts)) 107 | 108 | if (is.null(fills)) fills <- getOption("txp.fills", TXP_FILLS) 109 | if (nSlices > length(fills)) fills <- colorRampPalette(fills)(nSlices) 110 | if (nSlices < length(fills)) fills <- fills[1:nSlices] 111 | 112 | slices <- vector("list", nSlices) 113 | for (i in seq_along(rads)) { 114 | slices[[i]] <- makeSliceGrob(rad = rads[i], 115 | th0 = ths[i], 116 | th1 = ths[i + 1], 117 | fill = fills[i], 118 | name = gPath(sprintf("slice%s", i)), 119 | vp = vp) 120 | } 121 | do.call("gList", slices) 122 | } 123 | 124 | makePieViewport <- function() { 125 | vpStack(viewport(layout = grid.layout(nrow = 1, ncol = 1, respect = TRUE)), 126 | viewport(name = "pievp", 127 | layout.pos.row = 1, 128 | layout.pos.col = 1, 129 | xscale = c(-1, 1), 130 | yscale = c(-1, 1))) 131 | } 132 | 133 | ##----------------------------------------------------------------------------## 134 | 135 | -------------------------------------------------------------------------------- /vignettes/exportToGui.rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Export ToxPi GUI Files" 3 | output: rmarkdown::html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Export ToxPi GUI Files} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | %\VignetteEncoding{UTF-8} 8 | --- 9 | 14 | 15 | ```{r, include = FALSE} 16 | knitr::opts_chunk$set( 17 | collapse = TRUE, 18 | comment = "#>" 19 | ) 20 | ``` 21 | 22 | This vignette will show how to save a toxpiR model that will be compatible with the ToxPi Java GUI, which can be downloaded from [here](https://toxpi.org/). The toxpiR package and ToxPi Java GUI are not directly compatible and there are several key differences to keep in mind. 23 | 24 | ## Key differences between Java GUI and toxpiR 25 | 26 | ### Slice weights 27 | 28 | The Java GUI only allows weights that are either integers or a ratio of integers whereas the toxpiR package has no restrictions. The `txpExportGui()` function requires all weights to be integers, so the user may need to change the model weights to acceptable approximations prior to calling the export function. 29 | 30 | ### Transformation/scaling functions 31 | 32 | Currently the Java GUI only allows specific scaling functions and applies them independently to every input within a slice. The toxpiR package allows user-defined transformation functions at the input-level and slice-level. To account for these differences, all input-level transformation functions are applied before the data is exported. If slice-level transformations are applied, then the export function will create a data file that has the final slice scores rather than input-level data. 33 | 34 | The Java GUI does not allow negative input values and will treat them a missing data. This causes a problem if negative values exist after applying any user-defined transformations. If negative values occur within a slice, then all values of that slice will be shifted up by a constant so that no negative values remain. If a slice has both negative transformed values and missing values, then missing values are replaced with the added constant. In this last case, the toxpi and slice scores will be computed correctly, however, the Java GUI should not be used to compute bootstrapped confidence intervals because replacing missing data during the export process will cause the resampling step to be incorrect. 35 | 36 | ### Metrics in multiple slices 37 | 38 | The Java GUI does not allow multiple columns to have the same name, unless the data in those columns matches exactly. If a toxpiR model includes an input column in multiple slices, then the name will be appended with the slice index for each occurrence. 39 | 40 | ## Example use 41 | 42 | First create a toxpiR model with accompanying data. Here we'll load the "Format C" data example using the `txpImportGui()` function. 43 | 44 | ```{r} 45 | library(toxpiR) 46 | 47 | # Load example model from "Import ToxPi GUI Files" vignette 48 | data_format_C <- tempfile() 49 | download.file( 50 | url = "https://raw.githubusercontent.com/ToxPi/ToxPi-example-files/main/format_C.csv", 51 | destfile = data_format_C, 52 | quiet = TRUE 53 | ) 54 | gui1 <- txpImportGui(data_format_C) 55 | ``` 56 | 57 | Now we can use to export function to create a new data file. Notice the warnings for negative and missing values. 58 | 59 | ```{r} 60 | # Export back into GUI format 61 | data_exported <- tempfile() 62 | txpExportGui( 63 | fileName = data_exported, 64 | input = gui1$input, 65 | model = gui1$model, 66 | id.var = 'Name', 67 | fills = gui1$fills 68 | ) 69 | ``` 70 | 71 | ### Compare the data files 72 | 73 | Take a moment to observe differences between the original data file (`data_format_C`) and the exported version (`data_exported`). 74 | 75 | **`data_format_C`** 76 | 77 | ```{r echo=FALSE} 78 | knitr::kable(read.csv(data_format_C, header = FALSE, stringsAsFactors = FALSE)) 79 | ``` 80 | 81 | **`data_exported`** 82 | 83 |
84 | ```{r echo=FALSE} 85 | df <- read.csv(data_exported, header = FALSE, stringsAsFactors = FALSE) 86 | df[6:nrow(df), 2:ncol(df)] <- format(as.numeric(as.matrix(df[6:nrow(df), 2:ncol(df)])), digits = 4) 87 | knitr::kable(df) 88 | ``` 89 |
90 | 91 | ### Compare results 92 | 93 | Although the data files are visually different, they will result in the same toxpi and slice scores. 94 | 95 | ```{r} 96 | gui2 <- txpImportGui(data_exported) 97 | 98 | res1 <- txpCalculateScores(gui1$model, gui1$input) 99 | res2 <- txpCalculateScores(gui2$model, gui2$input) 100 | 101 | all.equal( 102 | txpScores(res1), 103 | txpScores(res2) 104 | ) 105 | 106 | all.equal( 107 | txpSliceScores(res1), 108 | txpSliceScores(res2) 109 | ) 110 | ``` 111 | -------------------------------------------------------------------------------- /tests/testthat/test-vsGuiResults.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## txpExportGui tests 3 | ##----------------------------------------------------------------------------## 4 | 5 | test_that("We reproduce GUI results", { 6 | 7 | # Get expected results from GUI output 8 | resExpected <- read.csv(file.path("guiFiles", "gui_test_results.csv"), check.names = FALSE) 9 | resExpected <- resExpected[order(resExpected$Name), -c(2:5)] 10 | names(resExpected) <- c('score', sapply(strsplit(names(resExpected)[-1], '!'), '[', 1)) 11 | 12 | ##------------------------------## 13 | # Using txpImportGui 14 | ##------------------------------## 15 | 16 | # Load data and model 17 | expect_warning({ 18 | gui1 <- txpImportGui(file.path("guiFiles", "gui_test_data.csv")) 19 | }) 20 | 21 | # Compute scores 22 | expect_silent({ 23 | res1 <- txpCalculateScores(gui1$model, gui1$input) 24 | }) 25 | 26 | # Compare ToxPi Scores 27 | expect_equal( 28 | txpScores(res1), 29 | resExpected$score, 30 | ignore_attr = TRUE 31 | ) 32 | 33 | # Compare Slice Scores 34 | expect_equal( 35 | as.data.frame(txpSliceScores(res1, adjusted = FALSE)), 36 | resExpected[,-1], 37 | ignore_attr = TRUE 38 | ) 39 | 40 | ##------------------------------## 41 | # Using output from txpExportGui 42 | ##------------------------------## 43 | 44 | # Export model, suppress expected warnings about containing negative values 45 | data_exported <- tempfile() 46 | expect_silent({ 47 | suppressWarnings( 48 | txpExportGui( 49 | fileName = data_exported, 50 | input = gui1$input, 51 | model = gui1$model, 52 | id.var = 'Name', 53 | fills = gui1$fills 54 | ) 55 | ) 56 | }) 57 | 58 | # Load data and model 59 | expect_silent({ 60 | gui2 <- txpImportGui(data_exported) 61 | }) 62 | 63 | # Compute scores 64 | expect_silent({ 65 | res2 <- txpCalculateScores(gui2$model, gui2$input) 66 | }) 67 | 68 | # Compare ToxPi Scores 69 | expect_equal( 70 | txpScores(res2), 71 | resExpected$score, 72 | ignore_attr = TRUE 73 | ) 74 | 75 | # Compare Slice Scores 76 | expect_equal( 77 | as.data.frame(txpSliceScores(res2, adjusted = FALSE)), 78 | resExpected[,-1], 79 | ignore_attr = TRUE 80 | ) 81 | 82 | ##------------------------------## 83 | # Manually created model 84 | ##------------------------------## 85 | 86 | # Create model 87 | input <- read.csv(file.path("guiFiles", "gui_test_data.csv"), skip = 40, check.names = FALSE, stringsAsFactors = FALSE) 88 | 89 | slices <- TxpSliceList() 90 | nFn <- 10 91 | for ( i in 1:nFn ) { 92 | fn <- switch( 93 | i, 94 | function(x) x, # 1: linear(x) 95 | function(x) as.integer(x != 0), # 2: hit count 96 | function(x) ifelse(x <= 0, NA, -log10(x)), # 3: -log10(x) 97 | function(x) ifelse(x <= 0, NA, -log10(x) + log10(max(x, na.rm = TRUE))), # 4: -log10(x)+log10(max(x)) 98 | function(x) ifelse(x <= 0, NA, -log10(x) + 6), # 5: -log10(x)+6 99 | function(x) ifelse(x <= 0, NA, -log(x)), # 6: -ln(x) 100 | function(x) ifelse(x <= 0, NA, log10(x)), # 7: log10(x) 101 | function(x) sqrt(x), # 8: sqrt(x) 102 | function(x) (x - mean(x, na.rm = TRUE))/sd(x, na.rm = TRUE), # 9: zscore(x) 103 | function(x) (x - min(x, na.rm = TRUE))/diff(range(x, na.rm = TRUE)), # 10: uniform(x) 104 | function(x) x # default 105 | ) 106 | addSlices <- TxpSliceList( 107 | b = TxpSlice(c("y1a", "y1b"), TxpTransFuncList(fn, fn)), 108 | a = TxpSlice("y1a", TxpTransFuncList(fn)), 109 | d = TxpSlice(c("y2a", "y2b"), TxpTransFuncList(fn, fn)), 110 | c = TxpSlice("y2a", TxpTransFuncList(fn)) 111 | ) 112 | names(addSlices) <- paste0('Slice', i, c('_1ab', '_1a', '_2ab', '_2a')) 113 | slices <- c(slices, addSlices) 114 | } 115 | 116 | expect_warning({ 117 | model <- TxpModel( 118 | txpSlices = slices, 119 | txpWeights = rep(c(2,1,2,1), nFn) 120 | ) 121 | }) 122 | 123 | # Compute scores 124 | expect_silent({ 125 | res3 <- txpCalculateScores(model, input, negative.value.handling = 'missing') 126 | }) 127 | 128 | # Compare ToxPi Scores 129 | expect_equal( 130 | txpScores(res3), 131 | resExpected$score, 132 | ignore_attr = TRUE 133 | ) 134 | 135 | # Compare Slice Scores 136 | expect_equal( 137 | as.data.frame(txpSliceScores(res3, adjusted = FALSE)), 138 | resExpected[,-1], 139 | ignore_attr = TRUE 140 | ) 141 | 142 | }) 143 | -------------------------------------------------------------------------------- /R/methods-TxpModelList.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## methods-txpModelList 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name TxpModelList-class 6 | #' @title List of TxpModel objects 7 | #' @description Extension of [S4Vectors::SimpleList] that holds only [TxpModel] 8 | #' objects. 9 | #' 10 | #' @param ... [TxpModel] object to create `TxpModelList` object 11 | #' @param x `TxpModelList` object 12 | #' 13 | #' @examples 14 | #' ## Create some TxpModel objects; see ?TxpModel for more details 15 | #' s1 <- list(S1 = TxpSlice("inpt1"), S2 = TxpSlice("inpt2")) 16 | #' tf <- list(NULL, sqrt = function(x) sqrt(x)) 17 | #' m1 <- TxpModel(txpSlices = s1, txpWeights = 2:1, txpTransFuncs = tf) 18 | #' m2 <- m1 19 | #' txpSlices(m2) <- list(S3 = TxpSlice("inpt3"), S4 = TxpSlice("inpt4")) 20 | #' m3 <- merge(m1, m2) 21 | #' 22 | #' ## Build a TxpModelList object 23 | #' TxpModelList(m1 = m1, m2 = m2, m3 = m3) 24 | #' 25 | #' ## Note: names are printed as '' when all are NULL 26 | #' TxpModelList(m1, m2, m3) 27 | #' names(TxpModelList(m1, m2, m3)) 28 | #' 29 | #' ## Test for duplicates 30 | #' duplicated(TxpModelList(m1 = m1, m2 = m2, m3 = m3)) 31 | #' duplicated(TxpModelList(m1 = m1, m2 = m1, m3 = m3)) 32 | #' 33 | #' ## Coerce lists/TxpModel objects to TxpModelList 34 | #' as(list(m1 = m1, m2 = m2, m3 = m3), "TxpModelList") 35 | #' as.TxpModelList(list(m1 = m1, m2 = m2, m3 = m3)) 36 | #' 37 | #' as(m1, "TxpModelList") 38 | #' as.TxpModelList(m1) 39 | 40 | NULL 41 | 42 | ##----------------------------------------------------------------------------## 43 | ## constructor 44 | 45 | #' @rdname TxpModelList-class 46 | #' @export 47 | 48 | TxpModelList <- function(...) { 49 | listData <- list(...) 50 | new2("TxpModelList", listData) 51 | } 52 | 53 | ##----------------------------------------------------------------------------## 54 | ## validity 55 | 56 | .TxpModelList.validity <- function(object) { 57 | msg <- NULL 58 | valid <- vapply(object@listData, is, logical(1), "TxpModel") 59 | if (any(!valid)) { 60 | msg <- c(msg, "All TxpModel objects must be of class 'TxpModel.'") 61 | } 62 | if (is.null(msg)) return(TRUE) 63 | msg 64 | } 65 | 66 | setValidity2("TxpModelList", .TxpModelList.validity) 67 | 68 | ##----------------------------------------------------------------------------## 69 | ## txpCalculateScores 70 | 71 | .TxpModelList.calc <- function(model, input, 72 | id.var = NULL, 73 | rank.ties.method = c("average", "first", "last", 74 | "random", "max", "min"), 75 | negative.value.handling = c("keep", "missing")) { 76 | if (is.list(model)) { 77 | model <- try(as.TxpModelList(model), silent = TRUE) 78 | if (is(model, "try-error")) { 79 | stop("Given list could not be coerced to TxpModelList") 80 | } 81 | } 82 | resLst <- lapply(model, .calculateScores, 83 | input = input, 84 | id.var = id.var, 85 | rank.ties.method = rank.ties.method, 86 | negative.value.handling = negative.value.handling) 87 | as.TxpResultList(resLst) 88 | } 89 | 90 | #' @rdname txpCalculateScores 91 | #' @export 92 | 93 | setMethod("txpCalculateScores", 94 | c("TxpModelList", "data.frame"), 95 | .TxpModelList.calc) 96 | 97 | #' @rdname txpCalculateScores 98 | #' @export 99 | 100 | setMethod("txpCalculateScores", c("list", "data.frame"), .TxpModelList.calc) 101 | 102 | ##----------------------------------------------------------------------------## 103 | ## show 104 | 105 | .TxpModelList.show <- function(object) { 106 | lnms <- .listDisplayNames(object) 107 | .coolcat(" TxpModelList of length %d: %s\n", lnms) 108 | } 109 | 110 | setMethod("show", "TxpModelList", .TxpModelList.show) 111 | 112 | ##----------------------------------------------------------------------------## 113 | ## duplicated 114 | 115 | #' @describeIn TxpModelList-class Returns logical vector of `length(x)`, where 116 | #' `TRUE` indicates a duplicate model in the list; see [base::duplicated] 117 | #' @export 118 | 119 | setMethod("duplicated", "TxpModelList", function(x) .dupList(x)) 120 | 121 | ##----------------------------------------------------------------------------## 122 | ## coercion 123 | 124 | .TxpModelList.from.list <- function(from) { 125 | do.call("TxpModelList", from) 126 | } 127 | 128 | setAs("list", "TxpModelList", .TxpModelList.from.list) 129 | 130 | .TxpModelList.from.TxpModel <- function(from) { 131 | TxpModelList(from) 132 | } 133 | 134 | setAs("TxpModel", "TxpModelList", .TxpModelList.from.TxpModel) 135 | 136 | #' @describeIn TxpModelList-class Coerce list or [TxpModel] objects to 137 | #' TxpModelList 138 | #' @export 139 | 140 | as.TxpModelList <- function(x) as(x, "TxpModelList") 141 | 142 | ##----------------------------------------------------------------------------## 143 | 144 | -------------------------------------------------------------------------------- /R/txpImportGui.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## txpImportGui 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name txpImportGui 6 | #' @title Import data file generated by ToxPi GUI 7 | #' @description Import data file generated by ToxPi GUI 8 | #' 9 | #' @param guiDataFile Character scalar, the path to a 'data' export from the 10 | #' ToxPi GUI 11 | #' 12 | #' @details 13 | #' This function takes the '_data.csv' files generated by the GUI. 14 | #' See \url{https://toxpi.org} for more information. 15 | #' 16 | #' Because of the way toxpiR implements transformation functions, there is not 17 | #' a way currently to use the GUI 'hitcount' function. 18 | #' 19 | #' @return `list` with `$model` containing [TxpModel] object; `$input` 20 | #' containing `data.frame` with input data; `$fills` containing a vector 21 | #' of fill colors. 22 | #' 23 | #' @importFrom utils type.convert read.csv 24 | #' @export 25 | 26 | txpImportGui <- function(guiDataFile) { 27 | 28 | stopifnot(is_scalar_character(guiDataFile)) 29 | stopifnot(file.exists(guiDataFile)) 30 | 31 | gui <- read.csv(guiDataFile, stringsAsFactors = FALSE, header = FALSE) 32 | res <- try(.fromGui(gui), silent = TRUE) 33 | if (is(res, "try-error")) stop("The given 'guiDataFile' could not be parsed.") 34 | if (is(res, "simpleCondition")) stop(conditionMessage(res)) 35 | res 36 | 37 | } 38 | 39 | #' @importFrom tidyr separate 40 | #' @importFrom rlang is_scalar_character 41 | 42 | .fromGui <- function(gui) { 43 | 44 | sliceInfoInd <- grepl('^#', gui[ , 1]) 45 | infoNms <- c("name", "wt", "col", "scale") 46 | sliceInfo <- tidyr::separate(data = gui[sliceInfoInd, ], 47 | col = "V1", 48 | into = infoNms, 49 | sep = "!", 50 | convert = FALSE) 51 | sliceInfo$name <- sub('^#\\s+', '', sliceInfo$name) 52 | sliceInfo$col <- sub('^0x', '#', sliceInfo$col) 53 | sliceInfo$wt <- sapply(strsplit(sliceInfo$wt, split = '/'), function(x) { 54 | as.numeric(x[1]) / as.numeric(ifelse(length(x) == 2, x[2], 1)) 55 | }) 56 | sliceInfo <- sliceInfo[ , infoNms] 57 | validFuncs <- sliceInfo$scale %in% names(TXP_GUI_FUNCS) 58 | if (!all(validFuncs)) { 59 | f <- paste(sliceInfo$scale[!validFuncs], collapse = ", ") 60 | msg <- sprintf(paste("Given scaling function(s), '%s', not compatible with", 61 | "toxpiR. See ?txpImportGui for more information."), 62 | f) 63 | return(simpleCondition(msg)) 64 | } 65 | sliceInfo$ind <- apply(gui[sliceInfoInd, ], 1, function(x) which(x == "x")) 66 | 67 | inputStart <- which(grepl('^row$', gui[ , 1], ignore.case = TRUE)) 68 | if (length(inputStart) != 1) { 69 | inputStart <- which(gui[ , 1] == '') # Format D 70 | } 71 | inputNms <- as.character(gui[inputStart, ]) 72 | input <- gui[(inputStart + 1):nrow(gui), ] 73 | input[] <- lapply(input, type.convert, as.is = TRUE) 74 | names(input) <- inputNms 75 | input[input < 0] <- NA 76 | row.names(input) <- 1:nrow(input) 77 | 78 | mkSl <- function(i) { 79 | s <- TxpSlice(txpValueNames = inputNms[sliceInfo[i, "ind"][[1]]]) 80 | sl <- length(s) 81 | tnm <- sliceInfo[i, "scale"] 82 | tfs <- .repFunc(TXP_GUI_FUNCS[[tnm]], sl) 83 | names(tfs) <- rep(tnm, sl) 84 | txpTransFuncs(s) <- tfs 85 | s 86 | } 87 | 88 | sliceLst <- lapply(seq(nrow(sliceInfo)), mkSl) 89 | names(sliceLst) <- sliceInfo$name 90 | sliceLst <- as.TxpSliceList(sliceLst) 91 | 92 | model <- TxpModel(txpSlices = sliceLst, txpWeights = sliceInfo[ , "wt"]) 93 | 94 | vnms <- unique(txpValueNames(txpSlices(model), simplify = TRUE)) 95 | numCols <- sapply(input[vnms], is.numeric) 96 | if (!all(numCols)) { 97 | cols <- paste(vnms[numCols], collapse = ", ") 98 | msg <- sprintf(paste("Following input column(s), '%s', could not be", 99 | "coerced to numeric."), 100 | cols) 101 | return(simpleCondition(msg)) 102 | } 103 | 104 | list(model = model, input = input, fills = sliceInfo$col) 105 | 106 | } 107 | 108 | #' @importFrom stats sd 109 | 110 | TXP_GUI_FUNCS <- list( 111 | 'linear(x)' = function(x) { x }, 112 | 'hit count' = function(x) { as.integer(x != 0) }, 113 | '-log10(x)' = function(x) { ifelse(x <= 0, NA, -log10(x)) }, 114 | '-log10(x)+log10(max(x))' = function(x) { 115 | ifelse(x <= 0, NA, -log10(x) + log10(max(x, na.rm = TRUE))) 116 | }, 117 | '-log10(x)+6' = function(x) { ifelse(x <= 0, NA, -log10(x) + 6) }, 118 | '-ln(x)' = function(x) { ifelse(x <= 0, NA, -log(x)) }, 119 | 'log10(x)' = function(x) { ifelse(x <= 0, NA, log10(x)) }, 120 | 'sqrt(x)' = function(x) { sqrt(x) }, 121 | 'zscore(x)' = function(x) { (x - mean(x, na.rm = TRUE))/sd(x, na.rm = TRUE) }, 122 | 'uniform(x)' = function(x) { 123 | xmn <- min(x, na.rm = TRUE) 124 | xmx <- max(x, na.rm = TRUE) 125 | (x - xmn)/(xmx - xmn) 126 | } 127 | ) 128 | 129 | ##----------------------------------------------------------------------------## 130 | 131 | -------------------------------------------------------------------------------- /tests/testthat/test-TxpModel.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## TxpModel tests 3 | ##----------------------------------------------------------------------------## 4 | 5 | ##----------------------------------------------------------------------------## 6 | ## Initialization 7 | 8 | test_that("We can create TxpModel objects", { 9 | expect_silent({ 10 | slcLst <- list(S1 = TxpSlice("input1"), S2 = TxpSlice("input2")) 11 | txpSlcLst <- TxpSliceList(S1 = TxpSlice("input1"), S2 = TxpSlice("input2")) 12 | fxnLst <- list(f1 = function(x) x, f2 = function(x) x^2) 13 | txpFxnLst <- TxpTransFuncList(f1 = function(x) x, f2 = function(x) x^2) 14 | wrnLst <- TxpSliceList(S1 = TxpSlice("input1"), S2 = TxpSlice("input1")) 15 | }) 16 | expect_s4_class(TxpModel(slcLst), "TxpModel") 17 | expect_s4_class(TxpModel(txpSlcLst), "TxpModel") 18 | expect_s4_class(TxpModel(txpSlices = slcLst, txpTransFuncs = fxnLst), 19 | "TxpModel") 20 | expect_s4_class(TxpModel(txpSlices = slcLst, txpTransFuncs = txpFxnLst), 21 | "TxpModel") 22 | expect_error(TxpModel(txpSlices = txpSlcLst, txpWeights = 1)) 23 | expect_error(TxpModel(txpSlices = txpSlcLst, txpWeights = "1")) 24 | expect_error(TxpModel(txpSlices = txpSlcLst, txpTransFuncs = txpFxnLst[1])) 25 | expect_warning(TxpModel(wrnLst)) 26 | }) 27 | 28 | ##----------------------------------------------------------------------------## 29 | ## Accessors 30 | 31 | test_that("TxpModel accessors return expected slots", { 32 | expect_silent({ 33 | sl <- TxpSliceList(S1 = TxpSlice("input1"), S2 = TxpSlice("input2")) 34 | md <- TxpModel(sl) 35 | }) 36 | expect_s4_class(txpSlices(md), "TxpSliceList") 37 | expect_equal(txpWeights(md), rep(1, 2)) 38 | expect_equal(txpWeights(md, adjust = TRUE), rep(0.5, 2)) 39 | expect_s4_class(txpTransFuncs(md), "TxpTransFuncList") 40 | expect_equal(txpValueNames(md), list(S1 = "input1", S2 = "input2")) 41 | expect_equal(txpValueNames(md, simplify = TRUE), 42 | c(S1 = "input1", S2 = "input2")) 43 | expect_named(md, c("S1", "S2")) 44 | expect_length(md, 2) 45 | }) 46 | 47 | ##----------------------------------------------------------------------------## 48 | ## Replace 49 | 50 | test_that("We can replace TxpModel slots", { 51 | expect_silent({ 52 | sl1 <- TxpSliceList(S1 = TxpSlice("input1"), S2 = TxpSlice("input2")) 53 | sl2 <- TxpSliceList(S1 = TxpSlice("input1"), S3 = TxpSlice("input3")) 54 | md <- TxpModel(sl1) 55 | fl <- TxpTransFuncList(f1 = function(x) x, f2 = function(x) sqrt(x)) 56 | }) 57 | expect_s4_class(txpSlices(md) <- sl2, "TxpSliceList") 58 | expect_named(txpSlices(md), c("S1", "S3")) 59 | expect_error(txpSlices(md) <- c("A", "B")) 60 | expect_error(txpSlices(md) <- c(sl1, sl2[2])) 61 | expect_silent(txpWeights(md) <- 1:2) 62 | expect_equal(txpWeights(md), 1:2) 63 | expect_silent(txpTransFuncs(md) <- fl) 64 | expect_named(txpTransFuncs(md), c("f1", "f2")) 65 | expect_silent(txpTransFuncs(md) <- as.list(fl)[2:1]) 66 | expect_named(txpTransFuncs(md), c("f2", "f1")) 67 | expect_silent(txpTransFuncs(md) <- NULL) 68 | expect_equal(txpTransFuncs(md), TxpTransFuncList(NULL, NULL)) 69 | md <- TxpModel(c(sl1, sl2[2])) 70 | names(md) <- c("A", "B", "C") 71 | expect_named(md, c("A", "B", "C")) 72 | expect_error(names(md) <- "hello") 73 | names(md)[2] <- "hello" 74 | expect_named(md, c("A", "hello", "C")) 75 | names(md)[2:3] <- c("B", "hello") 76 | expect_named(md, c("A", "B", "hello")) 77 | }) 78 | 79 | 80 | ##----------------------------------------------------------------------------## 81 | ## Show 82 | 83 | test_that("TxpModel show method displays correct information", { 84 | mdl <- TxpModel(txpSlices = TxpSliceList(S1 = TxpSlice("inpt1"), 85 | S2 = TxpSlice("input2")), 86 | txpWeights = 1:2, 87 | txpTransFuncs = list(f1 = function(x) x, NULL)) 88 | expect_output(print(mdl), "txpSlices\\(2\\)") 89 | expect_output(print(mdl), "S1 S2") 90 | expect_output(print(mdl), "txpWeights\\(2\\)") 91 | expect_output(print(mdl), "1 2") 92 | expect_output(print(mdl), "txpTransFuncs\\(2\\)") 93 | expect_output(print(mdl), "f1 NULL") 94 | }) 95 | 96 | ##----------------------------------------------------------------------------## 97 | ## Merge 98 | 99 | test_that("We can merge two TxpModel objects", { 100 | expect_silent({ 101 | m1 <- TxpModel(txpSlices = c(S1 = TxpSlice("inpt1"), 102 | S2 = TxpSlice("inpt2")), 103 | txpWeights = 1:2, 104 | txpTransFuncs = list(NULL, linear = function(x) x)) 105 | m2 <- TxpModel(txpSlices = c(S3 = TxpSlice("inpt3"), 106 | S4 = TxpSlice("inpt4")), 107 | txpWeights = 2:1, 108 | txpTransFuncs = list(linear = function(x) x, 109 | sqrt = function(x) sqrt(x))) 110 | m3 <- TxpModel(c(S1 = TxpSlice("inpt4"))) 111 | m4 <- TxpModel(c(S4 = TxpSlice("inpt1")), txpWeights = 3) 112 | }) 113 | expect_s4_class(mrg1 <- merge(m1, m2), "TxpModel") 114 | expect_length(mrg1, 4) 115 | expect_named(mrg1, c("S1", "S2", "S3", "S4")) 116 | expect_equal(names(txpTransFuncs(mrg1)), c("", "linear", "linear", "sqrt")) 117 | expect_equal(txpTransFuncs(mrg1)[[4]](100), 10) 118 | expect_equal(txpTransFuncs(mrg1)[[2]](100), 100) 119 | expect_error(txpTransFuncs(mrg1)[[1]](100)) 120 | expect_error(merge(m1, m3)) 121 | expect_warning(merge(m1, m4)) 122 | }) 123 | 124 | -------------------------------------------------------------------------------- /tests/testthat/test-TxpResultList.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## TxpResultList tests 3 | ##----------------------------------------------------------------------------## 4 | 5 | ##----------------------------------------------------------------------------## 6 | ## Initialization/txpCalculateScores 7 | 8 | test_that("We can create TxpResultList objects through txpCalculateScores", { 9 | data(txp_example_input, package = "toxpiR") 10 | sl <- TxpSliceList(s1 = TxpSlice(sprintf("metric%d", 1:2)), 11 | s2 = TxpSlice(sprintf("metric%d", 3:7))) 12 | md1 <- TxpModel(sl, txpWeights = c(2, 1)) 13 | md2 <- TxpModel(sl) 14 | md3 <- TxpModel(sl, 15 | txpTransFuncs = list(f1 = TxpTransFunc(), 16 | f2 = TxpTransFunc())) 17 | ml <- TxpModelList(md1, md2, md3) 18 | expect_s4_class(res <- txpCalculateScores(model = ml, 19 | input = txp_example_input, 20 | id.var = "name"), 21 | "TxpResultList") 22 | expect_s4_class(txpCalculateScores(model = as.list(ml), 23 | input = txp_example_input, 24 | id.var = "name"), 25 | "TxpResultList") 26 | expect_equal(txpModel(res[[1]]), md1) 27 | expect_equal(txpModel(res[[2]]), md2) 28 | expect_equal(txpModel(res[[3]]), md3) 29 | expect_error(TxpResultList(NULL)) 30 | expect_error(TxpResultList(NULL, res[[1]])) 31 | expect_error(TxpResultList(1)) 32 | expect_error(txpCalculateScores(model = c(as.list(ml), "hello"), 33 | input = txp_example_input, 34 | id.var = "name")) 35 | }) 36 | 37 | ##----------------------------------------------------------------------------## 38 | ## Show 39 | 40 | test_that("TxpResultList show method displays correct information", { 41 | expect_silent({ 42 | data(txp_example_input, package = "toxpiR") 43 | sl <- TxpSliceList(s1 = TxpSlice(sprintf("metric%d", 1:2)), 44 | s2 = TxpSlice(sprintf("metric%d", 3:7))) 45 | md1 <- TxpModel(sl, txpWeights = c(2, 1)) 46 | md2 <- TxpModel(sl) 47 | md3 <- TxpModel(sl, 48 | txpTransFuncs = list(f1 = TxpTransFunc(), 49 | f2 = TxpTransFunc())) 50 | ml <- TxpModelList(md1, m2 = md2, md3) 51 | l <- txpCalculateScores(model = ml, 52 | input = txp_example_input, 53 | id.var = "name") 54 | }) 55 | expect_output(print(l), "TxpResultList of length 3") 56 | expect_output(print(l), "'' m2 ''") 57 | expect_silent(names(l) <- NULL) 58 | expect_output(print(l), "'' '' ''") 59 | }) 60 | 61 | ##----------------------------------------------------------------------------## 62 | ## Concatenation 63 | 64 | test_that("We can concatenate TxpResultList objects", { 65 | expect_silent({ 66 | data(txp_example_input, package = "toxpiR") 67 | sl <- TxpSliceList(s1 = TxpSlice(sprintf("metric%d", 1:2)), 68 | s2 = TxpSlice(sprintf("metric%d", 3:7))) 69 | md1 <- TxpModel(sl, txpWeights = c(2, 1)) 70 | md2 <- TxpModel(sl) 71 | md3 <- TxpModel(sl, 72 | txpTransFuncs = list(f1 = TxpTransFunc(), 73 | f2 = TxpTransFunc())) 74 | ml <- TxpModelList(m1 = md1, md2, m3 = md3) 75 | l <- txpCalculateScores(model = ml, 76 | input = txp_example_input, 77 | id.var = "name") 78 | }) 79 | expect_s4_class(cl <- c(l, rev(l), l), "TxpResultList") 80 | expect_length(cl, 9) 81 | expect_named(cl, c('m1', '', 'm3', 'm3', '', 'm1', 'm1', '', 'm3')) 82 | }) 83 | 84 | ##----------------------------------------------------------------------------## 85 | ## Duplicated 86 | 87 | test_that("We can detect duplicate TxpResult objects in TxpResultList", { 88 | expect_silent({ 89 | data(txp_example_input, package = "toxpiR") 90 | sl <- TxpSliceList(s1 = TxpSlice(sprintf("metric%d", 1:2)), 91 | s2 = TxpSlice(sprintf("metric%d", 3:7))) 92 | md1 <- TxpModel(sl, txpWeights = c(2, 1)) 93 | md2 <- TxpModel(sl) 94 | ml1 <- TxpModelList(m1 = md1, m2 = md1) 95 | ml2 <- TxpModelList(m1 = md1, m2 = md2) 96 | l1 <- txpCalculateScores(model = ml1, 97 | input = txp_example_input, 98 | id.var = "name") 99 | l2 <- txpCalculateScores(model = ml2, 100 | input = txp_example_input, 101 | id.var = "name") 102 | }) 103 | expect_true(any(duplicated(l1))) 104 | expect_false(any(duplicated(l2))) 105 | }) 106 | 107 | ##----------------------------------------------------------------------------## 108 | ## Coercion 109 | 110 | test_that("We can coerce to TxpResultList objects", { 111 | expect_silent({ 112 | data(txp_example_input, package = "toxpiR") 113 | sl <- TxpSliceList(s1 = TxpSlice(sprintf("metric%d", 1:2)), 114 | s2 = TxpSlice(sprintf("metric%d", 3:7))) 115 | md1 <- TxpModel(sl, txpWeights = c(2, 1)) 116 | md2 <- TxpModel(sl) 117 | md3 <- TxpModel(sl, 118 | txpTransFuncs = list(f1 = TxpTransFunc(), 119 | f2 = TxpTransFunc())) 120 | ml <- TxpModelList(m1 = md1, md2, m3 = md3) 121 | l <- lapply(ml, txpCalculateScores, 122 | input = txp_example_input, 123 | id.var = "name") 124 | }) 125 | expect_s4_class(as.TxpResultList(l), "TxpResultList") 126 | expect_s4_class(as.TxpResultList(l[[1]]), "TxpResultList") 127 | }) 128 | 129 | -------------------------------------------------------------------------------- /R/methods-TxpSlice.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## methods-Slice 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name TxpSlice-class 6 | #' @title ToxPi Slice 7 | #' @description S4 class to store ToxPi slices 8 | #' 9 | #' @slot txpValueNames `vector()` specifying the input columns to 10 | #' include in the slice 11 | #' @slot txpTransFuncs [TxpTransFuncList] with one function per entry in 12 | #' `txpValueNames` or an object that can be coerced to `TxpTransFuncList`; 13 | #' when `NULL`, no transformation function applied 14 | #' 15 | #' 16 | #' @param txpValueNames Passed to `txpValueNames` slot 17 | #' @param txpTransFuncs Passed to `txpTransFuncs` slot 18 | #' @param x,y `TxpSlice` object 19 | #' @param value Replacement value 20 | #' 21 | #' @details 22 | #' If the user supplies `txpTransFuncs` a single function/[TxpTransFunc] object, 23 | #' the given function will be recycled for each input with a warning. 24 | #' 25 | #' @examples 26 | #' ## Create TxpSlice object 27 | #' # Without transform functions 28 | #' TxpSlice(txpValueNames = c("sqrData", "expData")) 29 | #' # With transform functions 30 | #' TxpSlice(txpValueNames = c("sqrData", "expData"), 31 | #' txpTransFuncs = c(sq = function(x) x^2, log = function(x) log(x))) 32 | #' 33 | #' # Transformation function recycled with warning when single function given 34 | #' TxpSlice(txpValueNames = c("sqrData", "expData"), 35 | #' txpTransFuncs = function(x) x^2) 36 | #' 37 | #' 38 | #' ## Access TxpSlice slots 39 | #' sl <- TxpSlice(txpValueNames = c("sqrData", "expData"), 40 | #' txpTransFuncs = c(sq = function(x) x^2, 41 | #' log = function(x) log(x))) 42 | #' txpValueNames(sl) 43 | #' txpTransFuncs(sl) 44 | #' 45 | #' ## Replacement 46 | #' txpValueNames(sl)[1] <- "hello" 47 | #' sl 48 | #' 49 | #' txpTransFuncs(sl)[[2]](exp(1)) 50 | #' txpTransFuncs(sl)[[2]] <- function(x) sqrt(x) 51 | #' txpTransFuncs(sl)[[2]](exp(1)) 52 | #' 53 | #' # Note that replacing a single list element does NOT update the name 54 | #' sl 55 | #' names(txpTransFuncs(sl))[2] <- "sqrt" 56 | #' sl 57 | #' 58 | #' # Replacing the whole list DOES update the names 59 | #' txpTransFuncs(sl) <- list(sqrt = function(x) sqrt(x), 60 | #' log = function(x) log(x)) 61 | #' sl 62 | #' 63 | #' ## length -- returns number of inputs 64 | #' length(TxpSlice(letters)) 65 | #' 66 | #' ## merge 67 | #' s1 <- TxpSlice("hello") 68 | #' s2 <- TxpSlice("data") 69 | #' merge(s1, s2) 70 | #' 71 | #' # Note, input names still must be unique 72 | #' \dontrun{merge(s1, s1)} ## produces error 73 | 74 | NULL 75 | 76 | ##----------------------------------------------------------------------------## 77 | ## constructor 78 | 79 | .TxpSlice.handle.funcs <- function(vn, tf) { 80 | vnl <- length(vn) 81 | if (is.null(tf)) tf <- vector("list", vnl) 82 | if (class(tf) %in% c("function", "TxpTransFunc") && vnl > 1) { 83 | warning("Recycling given 'txpTransFuncs' for each input.") 84 | tf <- .repFunc(tf, vnl) 85 | } 86 | if (!is(tf, "TxpTransFuncList")) { 87 | tf <- as.TxpTransFuncList(tf) 88 | } 89 | tf 90 | } 91 | 92 | #' @rdname TxpSlice-class 93 | #' @export 94 | 95 | TxpSlice <- function(txpValueNames, txpTransFuncs = NULL) { 96 | txpTransFuncs <- .TxpSlice.handle.funcs(txpValueNames, txpTransFuncs) 97 | new2("TxpSlice", txpValueNames = txpValueNames, txpTransFuncs = txpTransFuncs) 98 | } 99 | 100 | ##----------------------------------------------------------------------------## 101 | ## accessors 102 | 103 | #' @describeIn TxpSlice-class Return `txpValueNames` slot 104 | #' @export 105 | 106 | setMethod("txpValueNames", "TxpSlice", function(x) { x@txpValueNames }) 107 | 108 | #' @rdname TxpSlice-class 109 | #' @export 110 | 111 | setReplaceMethod("txpValueNames", "TxpSlice", function(x, value) { 112 | x@txpValueNames <- value 113 | validObject(x) 114 | x 115 | }) 116 | 117 | #' @describeIn TxpSlice-class Return `txpTransFuncs` slot 118 | #' @export 119 | 120 | setMethod("txpTransFuncs", "TxpSlice", function(x) { x@txpTransFuncs }) 121 | 122 | #' @rdname TxpSlice-class 123 | #' @export 124 | 125 | setReplaceMethod("txpTransFuncs", "TxpSlice", function(x, value) { 126 | value <- .TxpSlice.handle.funcs(txpValueNames(x), value) 127 | x@txpTransFuncs <- value 128 | validObject(x) 129 | x 130 | }) 131 | 132 | #' @describeIn TxpSlice-class Return number of inputs in slice; shortcut for 133 | #' `length(txpValueNames(x))` 134 | #' @export 135 | 136 | setMethod("length", "TxpSlice", function(x) { length(txpValueNames(x)) }) 137 | 138 | ##----------------------------------------------------------------------------## 139 | ## validity 140 | 141 | .TxpSlice.validity <- function(object) { 142 | msg <- NULL 143 | vl <- txpValueNames(object) 144 | fx <- txpTransFuncs(object) 145 | if (any(duplicated(vl))) { 146 | msg <- c(msg, "txpValueNames() must be unique.") 147 | } 148 | if (length(vl) != length(fx)) { 149 | tmp <- paste("length(txpValueNames()) !=", 150 | "length(txpTransFuncs())") 151 | msg <- c(msg, tmp) 152 | } 153 | if (is.null(msg)) return(TRUE) 154 | msg 155 | } 156 | 157 | setValidity2("TxpSlice", .TxpSlice.validity) 158 | 159 | ##----------------------------------------------------------------------------## 160 | ## show 161 | 162 | .TxpSlice.show <- function(object) { 163 | n <- length(txpValueNames(object)) 164 | cat(sprintf("TxpSlice with %d input%s.\n", n, ifelse(n > 1, "s", ""))) 165 | .coolcat(" txpValueNames(%d): %s\n", txpValueNames(object)) 166 | fnms <- .listDisplayNames(txpTransFuncs(object)) 167 | .coolcat(" txpTransFuncs(%d): %s\n", fnms) 168 | } 169 | 170 | setMethod("show", "TxpSlice", .TxpSlice.show) 171 | 172 | ##----------------------------------------------------------------------------## 173 | ## merge 174 | 175 | .TxpSlice.merge <- function(x, y) { 176 | vns <- c(txpValueNames(x), txpValueNames(y)) 177 | tfs <- c(txpTransFuncs(x), txpTransFuncs(y)) 178 | TxpSlice(txpValueNames = vns, txpTransFuncs = tfs) 179 | } 180 | 181 | #' @describeIn TxpSlice-class Merge two `TxpSlice` objects into a single 182 | #' slice 183 | #' @export 184 | 185 | setMethod("merge", c("TxpSlice", "TxpSlice"), .TxpSlice.merge) 186 | 187 | ##----------------------------------------------------------------------------## 188 | 189 | -------------------------------------------------------------------------------- /R/txpExportGui.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## txpExportGui 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name txpExportGui 6 | #' @title Export comma-separated file intended for ToxPi GUI 7 | #' @description Export comma-separated file intended for ToxPi GUI 8 | #' 9 | #' @param fileName Character scalar, the path to the output file 10 | #' @inheritParams txpCalculateScores 11 | #' @inheritParams pieGrob 12 | #' 13 | #' @details 14 | #' The GUI differs in two meaninful ways for exporting `toxpiR` models: (1) the 15 | #' GUI only allows for integer weights; (2) the GUI applies transformation 16 | #' functions differently. 17 | #' 18 | #' `txpExporGui` will not work for models with non-integer weights. 19 | #' 20 | #' The GUI only applies a single transformation function to every input within 21 | #' a slice, and only functions from a pre-determined list; `toxpiR` allows 22 | #' users to apply any valid function individually to each input, then a second 23 | #' transformation function on the summed slice values. Because of this 24 | #' complexity, any exported models with slice-level transformation functions 25 | #' will not export at the input level. In other words, the export will have only 26 | #' the final slice scores. Otherwise, all input-level transformations will be 27 | #' performed, the and the export will contain transformed input-level data with 28 | #' the `linear(x)` GUI transformation. 29 | #' 30 | #' @importFrom rlang is_scalar_character 31 | #' @importFrom utils write.table 32 | #' @export 33 | 34 | txpExportGui <- function(fileName = "txpModel.csv", 35 | input, 36 | model, 37 | id.var = NULL, 38 | fills = NULL) { 39 | 40 | ## TODO: fileName checks, can it be written? does it already exist? etc. 41 | 42 | stopifnot(is_scalar_character(fileName)) 43 | 44 | ## Test inputs 45 | .chkModelInput(model = model, input = input) 46 | 47 | ## Clean up infinite in input 48 | input <- .rmInfinite(model, input) 49 | 50 | slcWts <- txpWeights(model) 51 | if (any(slcWts%%1 != 0)) { 52 | stop("ToxPi GUI only allows integer weights in the model.") 53 | } 54 | 55 | ## Check for slice-level transformations 56 | tfs <- txpTransFuncs(model) 57 | if (any(!sapply(tfs, is.null))) { 58 | ## Output as completely transformed slice values 59 | warning("Model contains slice-level transformation; export will not ", 60 | "contain input-level data. See ?txpExportGui for more ", 61 | "information.") 62 | res <- .calculateScores(model = model, input = input) 63 | mat <- txpSliceScores(res) 64 | slcVec <- vnmVec <- colnames(mat) 65 | } else { 66 | ## Notes: may duplicate inputs because the same input in different slices 67 | ## can have different transformation functions 68 | vnmVec <- txpValueNames(model, simplify = TRUE) 69 | slcVec <- names(model) 70 | vnmLst <- txpValueNames(model) 71 | itfsLst <- txpTransFuncs(txpSlices(model)) 72 | matLst <- list() 73 | for (i in seq_along(vnmLst)) { 74 | mat <- matrix(NA_real_, nrow = NROW(input), ncol = length(vnmLst[[i]])) 75 | for (j in seq_along(vnmLst[[i]])) { 76 | if (is.null(itfsLst[[i]][[j]])) { 77 | mat[ , j] <- input[ , vnmLst[[i]][[j]]] 78 | } else { 79 | mat[ , j] <- itfsLst[[i]][[j]](input[ , vnmLst[[i]][[j]]]) 80 | } 81 | } 82 | # Make sure transformed values are positive 83 | minMat <- min(mat[is.finite(mat)]) 84 | if (minMat < 0) { 85 | x <- -floor(minMat) 86 | # If slices contain multiple components and any missing values, then those 87 | # missing values must be replaced with the added constant to produce the same 88 | # slice/toxpi scores because slice scores are computed by sum not mean 89 | # However, if all values are missing in a row, the leave it alone 90 | if (ncol(mat) > 1 & any(!is.finite(mat))) { 91 | idxNA <- apply(mat, 1, function(x) all(is.na(x))) 92 | mat[!idxNA & !is.finite(mat)] <- 0 93 | warning("Slice \"", slcVec[i], "\" contains both missing and negative values ", 94 | "after applying transformations so missing values were replaced with 0 ", 95 | "and then all values were increased by x = ", x, ".") 96 | } else { 97 | warning("Slice \"", slcVec[i], "\" contains negative values ", 98 | "after applying transformations so all values were increased by x = ", x, ".") 99 | } 100 | # Shift all values by a constant to make them positive 101 | mat <- mat + x 102 | } 103 | matLst[[i]] <- mat 104 | } 105 | mat <- do.call(cbind, matLst) 106 | } 107 | 108 | ## Make infinite NaN 109 | mat[is.infinite(mat)] <- NaN 110 | 111 | ## Determine colors 112 | nSlices <- length(slcVec) 113 | if (is.null(fills)) fills <- getOption("txp.fills", TXP_FILLS) 114 | if (nSlices > length(fills)) fills <- colorRampPalette(fills)(nSlices) 115 | if (nSlices < length(fills)) fills <- fills[1:nSlices] 116 | 117 | fills <- .col2hex(fills) 118 | fills <- sub("^#", "0x", fills) 119 | 120 | ## Rename any duplicated column names 121 | vnmLst <- txpValueNames(model) 122 | if (any(duplicated(vnmVec))) { 123 | dup <- unique(vnmVec[duplicated(vnmVec)]) 124 | for (i in seq_along(vnmLst)) { 125 | vnmLst[[i]] <- gsub(paste0('^(', paste(dup, collapse = '|'), ')$'), paste0('\\1_slice', i), vnmLst[[i]]) 126 | } 127 | vnmVec <- unlist(vnmLst) 128 | } 129 | 130 | ## Prepare the header 131 | slcMeta <- paste(slcVec, slcWts, fills, "linear(x)", sep = "!") 132 | slcMeta <- paste("#", slcMeta) 133 | slcVnmInd <- vector(mode = "list", length = nSlices) 134 | names(slcVnmInd) <- slcVec 135 | for (i in slcVec) { 136 | slcVnmInd[[i]] <- rep('', length(vnmVec)) 137 | slcVnmInd[[i]][vnmVec %in% vnmLst[[i]]] <- 'x' 138 | } 139 | hdr <- cbind(slcMeta, do.call(rbind, slcVnmInd)) 140 | 141 | ## Default names 142 | ids <- if (is.null(id.var)) 1:NROW(input) else input[[id.var]] 143 | 144 | ## Make final output 145 | out <- rbind(hdr, c('', vnmVec), cbind(ids, mat)) 146 | 147 | ## Write csv file 148 | write.table(x = out, 149 | file = fileName, 150 | quote = FALSE, 151 | sep = ",", 152 | row.names = FALSE, 153 | col.names = FALSE) 154 | 155 | } 156 | 157 | ##----------------------------------------------------------------------------## 158 | 159 | -------------------------------------------------------------------------------- /R/plotting-pieGridGrob.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## pieGridGrob 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name pieGridGrob 6 | #' @title Make grid of pieGrobs 7 | #' @description Make grid of pieGrobs 8 | #' 9 | #' @param radMat `matrix()`, observations by slice radii 10 | #' @param wts `vector()`, relative weights of each slice 11 | #' @param fills Vector of colors to fill slices 12 | #' @param labels `vector()`, (optional) label for each observation 13 | #' @param showRadSum Logical scalar, when `TRUE` show the weighted sum of slices 14 | #' below the label 15 | #' @param nrow,ncol Integer scalar, number of rows and columns for the grid 16 | #' @param byrow Logical scalar, fill the grid by rows when `TRUE` 17 | #' @param name,gp,vp Passed to [grid::gTree] 18 | #' 19 | #' @examples 20 | #' \donttest{ 21 | #' library(grid) 22 | #' 23 | #' s <- seq(0.2, 1, by = 0.1) 24 | #' smat <- do.call("rbind", replicate(20, s, simplify = FALSE)) 25 | #' grid.newpage() 26 | #' grid.pieGridGrob(radMat = smat) 27 | #' 28 | #' rownames(smat) <- sprintf("obs%02d", 1:20) 29 | #' grid.newpage() 30 | #' grid.pieGridGrob(radMat = smat, wts = s) 31 | #' grid.newpage() 32 | #' grid.pieGridGrob(radMat = smat, wts = s, showRadSum = TRUE, labels = FALSE) 33 | #' grid.newpage() 34 | #' grid.pieGridGrob(radMat = smat, labels = "hello") 35 | #' grid.newpage() 36 | #' grid.pieGridGrob(radMat = smat, labels = 1:20) 37 | #' 38 | #' ## Can edit like normal grid objects 39 | #' grid.newpage() 40 | #' grid.pieGridGrob(radMat = smat, wts = s, showRadSum = TRUE) 41 | #' grid.ls() ## shows grid elements 42 | #' grid.edit("pie-20", fills = 1:9) 43 | #' grid.edit("pie-19-label", gp = gpar(font = 2, col = "red")) 44 | #' grid.edit("pie-1", wts = rep(1, 9), rads = rep(1, 9)) 45 | #' for (s in sprintf("pie-%d-radSum", 2:4)) { 46 | #' grid.edit(s, gp = gpar(font = 2, col = "blue")) 47 | #' } 48 | #' } 49 | #' 50 | #' @return `pieGrob` [grid::grob] object 51 | #' 52 | #' @import grid 53 | #' @importFrom rlang is_scalar_integerish is_scalar_logical 54 | #' @importFrom grDevices colorRampPalette 55 | #' @export 56 | 57 | pieGridGrob <- function(radMat, wts = NULL, fills = NULL, labels = NULL, 58 | showRadSum = FALSE, ncol = NULL, nrow = NULL, 59 | byrow = TRUE, name = NULL, gp = NULL, vp = NULL) { 60 | 61 | nPie <- NROW(radMat) 62 | if (is.null(wts)) wts <- rep(1, NCOL(radMat)) 63 | wts <- wts/sum(wts) 64 | if (is.null(labels) || (is.logical(labels) && labels)) { 65 | labels <- rownames(radMat) 66 | } else { 67 | if (is.logical(labels) && !labels) labels <- NULL 68 | } 69 | pos <- makePieGridPos(nPie = nPie, nrow = nrow, ncol = ncol, byrow = byrow) 70 | pieGridVp <- makePieGridViewport(pos = pos, nPie = nPie) 71 | gTree(radMat = radMat, 72 | wts = wts, 73 | fills = fills, 74 | labels = labels, 75 | nPie = nPie, 76 | pos = pos, 77 | name = name, 78 | gp = gp, 79 | vp = vp, 80 | children = makePieGridGrob(radMat = radMat, 81 | pos = pos, 82 | wts = wts, 83 | fills = fills, 84 | labels = labels, 85 | showRadSum = showRadSum, 86 | vp = pieGridVp), 87 | childrenvp = pieGridVp, 88 | cls = "pieGridGrob") 89 | 90 | } 91 | 92 | #' @rdname pieGridGrob 93 | #' @export 94 | 95 | grid.pieGridGrob <- function(radMat, wts = NULL, fills = NULL, labels = NULL, 96 | showRadSum = FALSE, ncol = NULL, nrow = NULL, 97 | byrow = TRUE, name = NULL, gp = NULL, vp = NULL) { 98 | g <- pieGridGrob(radMat = radMat, 99 | wts = wts, 100 | fills = fills, 101 | labels = labels, 102 | showRadSum = showRadSum, 103 | ncol = ncol, 104 | nrow = nrow, 105 | byrow = byrow, 106 | name = name, 107 | vp = vp, 108 | gp = gp) 109 | grid.draw(g) 110 | } 111 | 112 | makePieGridPos <- function(nPie, nrow = NULL, ncol = NULL, byrow = TRUE) { 113 | stopifnot(is_scalar_integerish(nPie)) 114 | stopifnot(is.null(ncol) || is_scalar_integerish(ncol)) 115 | stopifnot(is.null(nrow) || is_scalar_integerish(nrow)) 116 | stopifnot(is_scalar_logical(byrow)) 117 | if (is.null(nrow) && is.null(ncol)) { 118 | ncol <- ceiling(sqrt(nPie)) 119 | nrow <- ceiling(nPie/ncol) 120 | } else { 121 | if (is.null(nrow)) nrow <- ceiling(nPie/ncol) 122 | if (is.null(ncol)) ncol <- ceiling(nPie/nrow) 123 | } 124 | 125 | if(byrow) { 126 | pos <- expand.grid(col = 1:ncol, row = 1:nrow) 127 | } else { 128 | pos <- expand.grid(row = 1:nrow, col = 1:ncol) 129 | } 130 | pos 131 | } 132 | 133 | makePieGridViewport <- function(pos, nPie) { 134 | nrow <- max(pos$row) 135 | ncol <- max(pos$col) 136 | gl <- grid.layout(nrow = nrow, 137 | ncol = ncol, 138 | widths = unit(rep_len(1, ncol), "null"), 139 | heights = unit(rep(1, nrow), "null")) 140 | gridVp <- viewport(layout = gl) 141 | pieBoxes <- vector("list", nPie) 142 | for (i in 1:nPie) { 143 | pieBoxes[[i]] <- viewport(name = sprintf("pieBox-%s", i), 144 | layout.pos.row = pos[i, "row"], 145 | layout.pos.col = pos[i, "col"]) 146 | } 147 | vpTree(gridVp, do.call("vpList", pieBoxes)) 148 | } 149 | 150 | makePieGridGrob <- function(radMat, pos, wts = NULL, fills = NULL, 151 | labels = NULL, showRadSum = FALSE, vp = NULL) { 152 | 153 | nPie <- NROW(radMat) 154 | pies <- vector("list", nPie) 155 | 156 | for (i in 1:nPie) { 157 | rads <- radMat[i, ] 158 | pies[[i]] <- frameGrob(vp = vpStack(vp$parent, vp$children[[i]])) 159 | pies[[i]] <- packGrob(frame = pies[[i]], 160 | grob = pieGrob(rads = rads, 161 | fills = fills, 162 | wts = wts, 163 | name = sprintf("pie-%s", i))) 164 | if (showRadSum) { 165 | rsum <- round(sum(rads*wts, na.rm = TRUE), 4) 166 | pies[[i]] <- packGrob(frame = pies[[i]], 167 | grob = textGrob(label = rsum, 168 | name = sprintf("pie-%s-radSum", i)), 169 | side = "top", 170 | height = unit(1.15, units = "char")) 171 | } 172 | 173 | if (!is.null(labels)) { 174 | pies[[i]] <- packGrob(frame = pies[[i]], 175 | grob = textGrob(label = labels[i], 176 | name = sprintf("pie-%s-label", i)), 177 | side = "top", 178 | height = unit(1.15, units = "char")) 179 | } 180 | } 181 | 182 | do.call("gList", pies) 183 | 184 | } 185 | 186 | ##----------------------------------------------------------------------------## 187 | 188 | -------------------------------------------------------------------------------- /man/TxpResult-class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/allClasses.R, R/methods-TxpResult.R 3 | \docType{class} 4 | \name{TxpResult-class} 5 | \alias{TxpResult-class} 6 | \alias{TxpResult} 7 | \alias{txpScores,TxpResult-method} 8 | \alias{txpSliceScores,TxpResult-method} 9 | \alias{txpRanks,TxpResult-method} 10 | \alias{txpMissing,TxpResult-method} 11 | \alias{txpResultParam,TxpResult-method} 12 | \alias{txpModel,TxpResult-method} 13 | \alias{txpIDs,TxpResult-method} 14 | \alias{txpIDs<-,TxpResult-method} 15 | \alias{txpWeights,TxpResult-method} 16 | \alias{txpSlices,TxpResult-method} 17 | \alias{txpTransFuncs,TxpResult-method} 18 | \alias{txpValueNames,TxpResult-method} 19 | \alias{[,TxpResult,logical,missing-method} 20 | \alias{[,TxpResult,integer,missing-method} 21 | \alias{[,TxpResult,numeric,missing-method} 22 | \alias{[,TxpResult,character,missing-method} 23 | \alias{length,TxpResult-method} 24 | \alias{sort,TxpResult-method} 25 | \alias{names,TxpResult-method} 26 | \alias{names<-,TxpResult-method} 27 | \alias{as.data.frame,TxpResult-method} 28 | \title{ToxPi Result} 29 | \usage{ 30 | \S4method{txpScores}{TxpResult}(x) 31 | 32 | \S4method{txpSliceScores}{TxpResult}(x, adjusted = TRUE) 33 | 34 | \S4method{txpRanks}{TxpResult}(x) 35 | 36 | \S4method{txpMissing}{TxpResult}(x) 37 | 38 | \S4method{txpResultParam}{TxpResult}(x) 39 | 40 | \S4method{txpModel}{TxpResult}(x) 41 | 42 | \S4method{txpIDs}{TxpResult}(x) 43 | 44 | \S4method{txpIDs}{TxpResult}(x) <- value 45 | 46 | \S4method{txpWeights}{TxpResult}(x, adjusted = FALSE) 47 | 48 | \S4method{txpSlices}{TxpResult}(x) 49 | 50 | \S4method{txpTransFuncs}{TxpResult}(x, level, simplify = FALSE) 51 | 52 | \S4method{txpValueNames}{TxpResult}(x, simplify = FALSE) 53 | 54 | \S4method{[}{TxpResult,logical,missing}(x, i, j, ..., drop = FALSE) 55 | 56 | \S4method{[}{TxpResult,integer,missing}(x, i, j, ..., drop = FALSE) 57 | 58 | \S4method{[}{TxpResult,numeric,missing}(x, i, j, ..., drop = FALSE) 59 | 60 | \S4method{[}{TxpResult,character,missing}(x, i, j, ..., drop = FALSE) 61 | 62 | \S4method{length}{TxpResult}(x) 63 | 64 | \S4method{sort}{TxpResult}(x, decreasing = TRUE, na.last = TRUE, ...) 65 | 66 | \S4method{names}{TxpResult}(x) 67 | 68 | \S4method{names}{TxpResult}(x) <- value 69 | 70 | \S4method{as.data.frame}{TxpResult}( 71 | x, 72 | row.names = NULL, 73 | optional = FALSE, 74 | ..., 75 | id.name = "id", 76 | score.name = "score", 77 | rank.name = "rank", 78 | adjusted = FALSE 79 | ) 80 | } 81 | \arguments{ 82 | \item{x}{\link{TxpResult} object} 83 | 84 | \item{adjusted}{Logical scalar, when \code{TRUE} the weights are adjusted to sum 85 | to 1 or the slice scores are scaled to their respective weight} 86 | 87 | \item{value}{Replacement value} 88 | 89 | \item{level}{\code{c('model', 'slices')}; indicates whether to retrieve 90 | \code{txpTransFuncs} slot from the model or underlying slices} 91 | 92 | \item{simplify}{Logical scalar, flatten \code{txpValueNames} or \code{txpTransFunc} 93 | slots when retrieving slice-level information} 94 | 95 | \item{i}{Subsetting index} 96 | 97 | \item{j, drop, optional}{Not currently implemented} 98 | 99 | \item{...}{Passed to \link[base:data.frame]{base::data.frame} in \code{as.data.frame} or \link[base:sort]{base::sort} 100 | in \code{sort}} 101 | 102 | \item{decreasing, na.last}{Passed to \link[base:sort]{base::sort}} 103 | 104 | \item{row.names}{Passed to \link[base:data.frame]{base::data.frame}} 105 | 106 | \item{id.name, score.name, rank.name}{Character scalar; when coercing to 107 | \link[base:data.frame]{base::data.frame}, the name for the \code{txpIDs}, \code{txpScores}, and \code{txpRanks} 108 | columns, respectively} 109 | } 110 | \description{ 111 | S4 class to store ToxPi results 112 | } 113 | \section{Functions}{ 114 | \itemize{ 115 | \item \code{txpScores(TxpResult)}: Return \code{txpScores} slot 116 | 117 | \item \code{txpSliceScores(TxpResult)}: Return \code{txpSliceScores} slot; default 118 | \code{adjusted = TRUE}, i.e. return slice scores adjusted for weight 119 | 120 | \item \code{txpRanks(TxpResult)}: Return \code{txpRanks} slot 121 | 122 | \item \code{txpMissing(TxpResult)}: Return \code{txpMissing} slot 123 | 124 | \item \code{txpResultParam(TxpResult)}: Return \code{txpResultParam} slot 125 | 126 | \item \code{txpModel(TxpResult)}: Return \code{txpModel} slot 127 | 128 | \item \code{txpIDs(TxpResult)}: Return \code{txpIDs} slot 129 | 130 | \item \code{txpWeights(TxpResult)}: Return \code{txpWeights} slot from model -- shortcut 131 | for \code{txpWeights(txpModel(x))}; default \code{adjusted = FALSE}, i.e. return 132 | unadjusted weights 133 | 134 | \item \code{txpSlices(TxpResult)}: Return \code{txpSlices} slot from model -- shortcut 135 | for \code{txpSlices(txpModel(x))} 136 | 137 | \item \code{txpTransFuncs(TxpResult)}: Return \code{txpTransFuncs} slot from model -- 138 | shortcut for \code{txpTransFuncs(txpModel(x))} 139 | 140 | \item \code{txpValueNames(TxpResult)}: Return \code{txpValueNames} slot from slices -- 141 | shortcut for \code{txpValueNames(txpSlices(txpModel(x)))} 142 | 143 | \item \code{length(TxpResult)}: Return the number of observations; shortcut for 144 | \code{length(txpScores(x))} 145 | 146 | \item \code{sort(TxpResult)}: Sort the ``TxpResult` object by their ranks 147 | 148 | \item \code{names(TxpResult)}: Returns IDs; equal to \code{txpIDs(x)} 149 | 150 | \item \code{as.data.frame(TxpResult)}: Coerce TxpResult to \link[base:data.frame]{base::data.frame} object 151 | with IDs, scores, ranks, and slice scores 152 | 153 | }} 154 | \section{Slots}{ 155 | 156 | \describe{ 157 | \item{\code{txpScores}}{\verb{vector()} of model scores} 158 | 159 | \item{\code{txpSliceScores}}{\verb{matrix()}, sample by slice \code{matrix} with 160 | individual slice scores} 161 | 162 | \item{\code{txpRanks}}{\verb{vector()} with rank of scores} 163 | 164 | \item{\code{txpMissing}}{\verb{vector()} with data missingness} 165 | 166 | \item{\code{txpModel}}{\link{TxpModel} object} 167 | 168 | \item{\code{txpIDs}}{\verb{vector()} of observation IDs} 169 | 170 | \item{\code{txpResultParam}}{\link{TxpResultParam} object} 171 | }} 172 | 173 | \examples{ 174 | ## Load example dataset & model; see ?TxpModel for building model objects 175 | data(txp_example_input, package = "toxpiR") 176 | data(txp_example_model, package = "toxpiR") 177 | 178 | ## Calculate scores for single model; returns TxpResult object 179 | res <- txpCalculateScores(model = txp_example_model, 180 | input = txp_example_input, 181 | id.var = "name") 182 | 183 | ## Accessors 184 | txpScores(res) 185 | 186 | txpSliceScores(res) ## adjusted for weight, by default 187 | apply(txpSliceScores(res), 2, max, na.rm = TRUE) 188 | 189 | txpSliceScores(res, adjusted = FALSE) ## each score should have maximum of 1 190 | apply(txpSliceScores(res, adjusted = FALSE), 2, max, na.rm = TRUE) 191 | 192 | txpRanks(res) 193 | 194 | txpMissing(res) 195 | 196 | txpModel(res) 197 | identical(txpModel(res), txp_example_model) 198 | 199 | txpIDs(res) 200 | names(res) ## identical to txpIDs(res) 201 | identical(txpIDs(res), names(res)) 202 | 203 | # Can access TxpModel slots directly 204 | txpWeights(res) 205 | txpWeights(res, adjusted = TRUE) 206 | txpSlices(res) 207 | # When retrieving transform functions, must specify level because both 208 | # models and slices have transform functions 209 | txpTransFuncs(res, level = "model") 210 | 211 | # Can access TxpSliceList slots directly 212 | txpValueNames(res) 213 | txpValueNames(res, simplify = TRUE) 214 | txpTransFuncs(res, level = "slices") 215 | txpTransFuncs(res, level = "slices", simplify = TRUE) 216 | 217 | ## Subsetting 218 | res[1] 219 | res[c("chem01", "chem09")] 220 | res[grepl("4|6", txpIDs(res))] 221 | \dontrun{ 222 | res[c(TRUE, FALSE)] ## gets recycled with warning 223 | } 224 | 225 | ## length -- returns number of observations 226 | length(res) 227 | length(res[1:5]) 228 | 229 | ## sort 230 | names(res) 231 | names(sort(res)) 232 | 233 | txpScores(res) 234 | txpScores(sort(res)) 235 | txpScores(sort(res, decreasing = FALSE)) 236 | 237 | ## as.data.frame 238 | as.data.frame(res) 239 | as.data.frame(res, id.name = "nm", score.name = "scr", rank.name = "rnk") 240 | } 241 | \seealso{ 242 | \link{txpCalculateScores}, \link{plot}, \link{TxpResultList} 243 | } 244 | -------------------------------------------------------------------------------- /R/methods-TxpModel.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## methods-TxpModel 3 | ##----------------------------------------------------------------------------## 4 | 5 | #' @name TxpModel-class 6 | #' @title ToxPi Model 7 | #' @description S4 class to store ToxPi models 8 | #' 9 | #' @slot txpSlices [TxpSliceList] object 10 | #' @slot txpWeights numeric vector specifying the relative weight of each slice; 11 | #' when NULL, defaults to 1 (equal weighting) for each slice 12 | #' @slot txpTransFuncs [TxpTransFuncList] object (or list of functions 13 | #' coercible to TxpTransFuncList) 14 | #' 15 | #' @param txpSlices Passed to `txpSlices` slot 16 | #' @param txpWeights Passed to `txpWeights` slot 17 | #' @param txpTransFuncs Passed to `txpTransFuncs` slot 18 | #' @param x,y TxpModel object 19 | #' @param value Replacement value 20 | #' @param adjusted Scalar logical, when `TRUE` weights are adjusted to sum to 1 21 | #' @param simplify Scalar logical, when `TRUE` the returned `list` is simplified 22 | #' 23 | #' @examples 24 | #' ## Create TxpSliceList & TxpTransFuncList objects 25 | #' s1 <- list(S1 = TxpSlice("inpt1"), S2 = TxpSlice("inpt2")) 26 | #' tf <- list(NULL, sqrt = function(x) sqrt(x)) 27 | #' 28 | #' ## Create TxpModel object 29 | #' m1 <- TxpModel(txpSlices = s1, txpWeights = 2:1, txpTransFuncs = tf) 30 | #' m1 31 | #' 32 | #' ## Access TxpModel slots 33 | #' txpSlices(m1) 34 | #' txpWeights(m1) 35 | #' txpWeights(m1, adjusted = TRUE) 36 | #' txpTransFuncs(m1) 37 | #' 38 | #' ## length 39 | #' length(m1) ## equal to length(txpSlices(m1)) 40 | #' length(m1) == length(txpSlices(m1)) 41 | #' 42 | #' ## names 43 | #' names(m1) ## equal to names(txpSlices(m1)) 44 | #' all(names(m1) == names(txpSlices(m1))) 45 | #' 46 | #' ## Replacement 47 | #' m2 <- m1 48 | #' txpSlices(m2) <- list(S3 = TxpSlice("inpt3"), S4 = TxpSlice("inpt4")) 49 | #' m2 50 | #' names(m2)[2] <- "hello" 51 | #' names(m2) 52 | #' txpTransFuncs(m2) <- NULL 53 | #' m2 54 | #' txpTransFuncs(m2)[[1]] <- function(x) x^2 55 | #' names(txpTransFuncs(m2))[1] <- "sq" 56 | #' m2 57 | #' 58 | #' ## merge 59 | #' m3 <- merge(m1, m2) 60 | #' m3 61 | 62 | NULL 63 | 64 | ##----------------------------------------------------------------------------## 65 | ## constructor 66 | 67 | #' @rdname TxpModel-class 68 | #' @export 69 | 70 | TxpModel <- function(txpSlices, txpWeights = NULL, txpTransFuncs = NULL) { 71 | if (!is(txpSlices, "TxpSliceList")) txpSlices <- as.TxpSliceList(txpSlices) 72 | n <- length(txpSlices) 73 | if (is.null(txpWeights)) txpWeights <- rep(1, n) 74 | if (is.null(txpTransFuncs)) { 75 | txpTransFuncs <- as(List(vector("list", n)), "TxpTransFuncList") 76 | } 77 | if (!is(txpTransFuncs, "TxpTransFuncList")) { 78 | txpTransFuncs <- as.TxpTransFuncList(txpTransFuncs) 79 | } 80 | new2("TxpModel", 81 | txpSlices = txpSlices, 82 | txpWeights = txpWeights, 83 | txpTransFuncs = txpTransFuncs) 84 | } 85 | 86 | ##----------------------------------------------------------------------------## 87 | ## accessors 88 | 89 | #' @describeIn TxpModel-class Return `txpSlices` slot 90 | #' @aliases TxpModel-txpSlices 91 | #' @export 92 | 93 | setMethod("txpSlices", "TxpModel", function(x) { 94 | x@txpSlices 95 | }) 96 | 97 | #' @rdname TxpModel-class 98 | #' @export 99 | 100 | setReplaceMethod("txpSlices", "TxpModel", function(x, value) { 101 | if (!is(value, "TxpSliceList")) value <- as.TxpSliceList(value) 102 | x@txpSlices <- value 103 | validObject(x) 104 | x 105 | }) 106 | 107 | #' @describeIn TxpModel-class Return `txpWeights` slot 108 | #' @param adjusted Scalar logical, should the returned weights be adjusted 109 | #' such that they sum to 1? 110 | #' @importFrom rlang is_scalar_logical 111 | #' @export 112 | 113 | setMethod("txpWeights", "TxpModel", function(x, adjusted = FALSE) { 114 | stopifnot(is_scalar_logical(adjusted)) 115 | wts <- x@txpWeights 116 | if (adjusted) wts <- wts/sum(wts) 117 | wts 118 | }) 119 | 120 | #' @rdname TxpModel-class 121 | #' @export 122 | 123 | setReplaceMethod("txpWeights", "TxpModel", function(x, value) { 124 | x@txpWeights <- value 125 | validObject(x) 126 | x 127 | }) 128 | 129 | #' @describeIn TxpModel-class Return `txpTransFuncs` slot 130 | #' @export 131 | 132 | setMethod("txpTransFuncs", "TxpModel", function(x) { 133 | x@txpTransFuncs 134 | }) 135 | 136 | #' @rdname TxpModel-class 137 | #' @export 138 | 139 | setReplaceMethod("txpTransFuncs", "TxpModel", function(x, value) { 140 | if (is.null(value)) value <- vector("list", length(x)) 141 | if (!is(value, "TxpTransFuncList")) value <- as.TxpTransFuncList(value) 142 | x@txpTransFuncs <- value 143 | validObject(x) 144 | x 145 | }) 146 | 147 | #' @describeIn TxpModel-class Return `list` of `txpValueNames` slots for the 148 | #' contained [TxpSliceList] object, or `vector` when `simplify = TRUE` 149 | #' @importFrom rlang is_scalar_logical 150 | #' @export 151 | 152 | setMethod("txpValueNames", "TxpModel", function(x, simplify = FALSE) { 153 | stopifnot(is_scalar_logical(simplify)) 154 | nms <- txpValueNames(txpSlices(x), simplify = simplify) 155 | nms 156 | }) 157 | 158 | #' @describeIn TxpModel-class Return slice names; shortcut for 159 | #' `names(txpSlices(x))` 160 | #' @export 161 | 162 | setMethod("names", "TxpModel", function(x) { 163 | names(txpSlices(x)) 164 | }) 165 | 166 | #' @rdname TxpModel-class 167 | #' @export 168 | 169 | setReplaceMethod("names", "TxpModel", function(x, value) { 170 | names(x@txpSlices) <- value 171 | validObject(x, complete = TRUE) 172 | x 173 | }) 174 | 175 | .TxpModel.calc <- function(model, input, 176 | id.var = NULL, 177 | rank.ties.method = c("average", "first", "last", 178 | "random", "max", "min"), 179 | negative.value.handling = c("keep", "missing")) { 180 | .calculateScores(model = model, 181 | input = input, 182 | id.var = id.var, 183 | rank.ties.method = rank.ties.method, 184 | negative.value.handling = negative.value.handling) 185 | } 186 | 187 | #' @describeIn TxpModel-class Return number of slices in model; shortcut for 188 | #' `length(txpSlices(x))` 189 | #' @export 190 | 191 | setMethod("length", "TxpModel", function(x) { 192 | length(txpSlices(x)) 193 | }) 194 | 195 | #' @rdname txpCalculateScores 196 | #' @export 197 | 198 | setMethod("txpCalculateScores", c("TxpModel", "data.frame"), .TxpModel.calc) 199 | 200 | ##----------------------------------------------------------------------------## 201 | ## validity 202 | 203 | .TxpModel.validity <- function(object) { 204 | msg <- NULL 205 | sl <- txpSlices(object) 206 | wt <- txpWeights(object) 207 | tf <- txpTransFuncs(object) 208 | if (length(sl) != length(wt)) { 209 | tmp <- "length(txpSlices()) != length(txpWeights())" 210 | msg <- c(msg, tmp) 211 | } 212 | if (length(sl) != length(tf)) { 213 | tmp <- "length(txpSlices()) != length(txpTransFuncs())" 214 | msg <- c(msg, tmp) 215 | } 216 | valNms <- txpValueNames(sl, simplify = TRUE) 217 | valDup <- duplicated(valNms) 218 | if (any(valDup)) { 219 | dup <- valNms[valDup] 220 | wrn <- "The following 'input' columns are duplicated in the model:\n %s" 221 | warning(sprintf(wrn, paste(dup, collapse = ", "))) 222 | } 223 | if (is.null(msg)) return(TRUE) 224 | msg 225 | } 226 | 227 | setValidity2("TxpModel", .TxpModel.validity) 228 | 229 | ##----------------------------------------------------------------------------## 230 | ## show 231 | 232 | .TxpModel.show <- function(object) { 233 | fnms <- .listDisplayNames(txpTransFuncs(object)) 234 | cat(sprintf("TxpModel with %d slices.\n", length(txpSlices(object)))) 235 | .coolcat("txpSlices(%d): %s\n", names(txpSlices(object))) 236 | .coolcat("txpWeights(%d): %s\n", txpWeights(object)) 237 | .coolcat("txpTransFuncs(%d): %s\n", fnms) 238 | } 239 | 240 | setMethod("show", "TxpModel", .TxpModel.show) 241 | 242 | ##----------------------------------------------------------------------------## 243 | ## merge 244 | 245 | .TxpModel.merge <- function(x, y) { 246 | sls <- c(txpSlices(x), txpSlices(y)) 247 | wts <- c(txpWeights(x), txpWeights(y)) 248 | tfs <- c(txpTransFuncs(x), txpTransFuncs(y)) 249 | TxpModel(txpSlices = sls, txpWeights = wts, txpTransFuncs = tfs) 250 | } 251 | 252 | #' @describeIn TxpModel-class Merge two `TxpModel` objects into a single 253 | #' model 254 | #' @export 255 | 256 | setMethod("merge", c("TxpModel", "TxpModel"), .TxpModel.merge) 257 | 258 | ##----------------------------------------------------------------------------## 259 | -------------------------------------------------------------------------------- /tests/testthat/test-TxpResult.R: -------------------------------------------------------------------------------- 1 | ##----------------------------------------------------------------------------## 2 | ## TxpResult/txpCalculateScores tests 3 | ##----------------------------------------------------------------------------## 4 | 5 | ##----------------------------------------------------------------------------## 6 | ## txpCalculateScores 7 | 8 | test_that("We can create TxpResult objects through txpCalculateScores", { 9 | data(txp_example_input, package = "toxpiR") 10 | data(txp_example_model, package = "toxpiR") 11 | expect_s4_class(res <- txpCalculateScores(model = txp_example_model, 12 | input = txp_example_input, 13 | id.var = "name"), 14 | "TxpResult") 15 | inf_example <- txp_example_input 16 | inf_example["chem4", "metric1"] <- Inf 17 | expect_warning(inf_res <- txpCalculateScores(model = txp_example_model, 18 | input = inf_example, 19 | id.var = "name")) 20 | expect_s4_class(inf_res, "TxpResult") 21 | txpValueNames(txpSlices(txp_example_model)[[2]]) <- "notInput" 22 | expect_error(txpCalculateScores(model = txp_example_model, 23 | input = txp_example_input)) 24 | txp_example_input$notInput <- "hello" 25 | expect_error(txpCalculateScores(model = txp_example_model, 26 | input = txp_example_input)) 27 | }) 28 | 29 | ##----------------------------------------------------------------------------## 30 | ## Accessors 31 | 32 | test_that("TxpResult accessors return expected slots", { 33 | data(txp_example_input, package = "toxpiR") 34 | data(txp_example_model, package = "toxpiR") 35 | expect_s4_class(res <- txpCalculateScores(model = txp_example_model, 36 | input = txp_example_input, 37 | id.var = "name"), 38 | "TxpResult") 39 | expect_s4_class(txpModel(res), "TxpModel") 40 | expect_type(txpScores(res), "double") 41 | expect_type(txpIDs(res), "character") 42 | expect_equal(txpIDs(res), sprintf("chem%02d", 1:10)) 43 | expect_type(txpSliceScores(res), "double") 44 | expect_true(is.matrix(txpSliceScores(res))) 45 | expect_equal(dim(txpSliceScores(res)), c(10, 4)) 46 | expect_equal(rowSums(txpSliceScores(res, adjusted = TRUE)), txpScores(res)) 47 | expect_equal(apply(txpSliceScores(res, adjusted = FALSE), 2, max), 48 | c(s1 = 1, s2 = 1, s3 = 1, s4 = 1)) 49 | expect_equal(txpRanks(sort(res)), 1:10) 50 | expect_equal(txpRanks(sort(res, decreasing = FALSE)), 10:1) 51 | expect_s4_class(txpSlices(res), "TxpSliceList") 52 | expect_length(txpSlices(res), 4) 53 | expect_equal(round(txpScores(res), 6), 54 | c(0.863316, 0.414845, 0.347997, 0.164044, 0.425231, 55 | 0.585716, 0.000000, 0.719512, 0.771979, 0.470999)) 56 | expect_equal(txpTransFuncs(res, level = "model"), 57 | txpTransFuncs(txpModel(res))) 58 | expect_equal(txpTransFuncs(res, level = "slices"), 59 | txpTransFuncs(txpSlices(txpModel(res)))) 60 | expect_equal(txpTransFuncs(res, level = "slices", simplify = TRUE), 61 | txpTransFuncs(txpSlices(txpModel(res)), simplify = TRUE)) 62 | expect_equal(txpValueNames(res), txpValueNames(txpSlices(txpModel(res)))) 63 | expect_equal(txpValueNames(res, simplify = TRUE), 64 | txpValueNames(txpSlices(txpModel(res)), simplify = TRUE)) 65 | expect_type(txpMissing(res), "double") 66 | expect_equal(length(txpMissing(res)), length(txpSlices(res))) 67 | expect_true(all(txpMissing(res) >=0 & txpMissing(res) <=1)) 68 | expect_equal(txpMissing(res), c(s1 = 0.1,s2 =0.1,s3 =0.125,s4 =0.1)) 69 | }) 70 | 71 | ##----------------------------------------------------------------------------## 72 | ## Replacement 73 | 74 | test_that("We can replace TxpResult names/txpIDs", { 75 | expect_silent({ 76 | data(txp_example_input, package = "toxpiR") 77 | data(txp_example_model, package = "toxpiR") 78 | res <- txpCalculateScores(model = txp_example_model, 79 | input = txp_example_input, 80 | id.var = "name") 81 | oldNms <- names(res) 82 | newNms <- as.character(sprintf("new%02d", 1:10)) 83 | }) 84 | expect_named({names(res) <- newNms; res}, newNms) 85 | expect_named({txpIDs(res) <- oldNms; res}, oldNms) 86 | expect_named({txpIDs(res)[1] <- "hello"; res[1]}, "hello") 87 | expect_named({names(res)[8:9] <- newNms[8:9]; res[8:9] }, newNms[8:9]) 88 | expect_error(names(res) <- letters) 89 | }) 90 | 91 | ##----------------------------------------------------------------------------## 92 | ## Subsetting 93 | 94 | test_that("TxpResult accessors return expected slots", { 95 | expect_silent({ 96 | data(txp_example_input, package = "toxpiR") 97 | data(txp_example_model, package = "toxpiR") 98 | res <- txpCalculateScores(model = txp_example_model, 99 | input = txp_example_input, 100 | id.var = "name") 101 | }) 102 | expect_s4_class(res[1], "TxpResult") 103 | expect_length(res[1], 1) 104 | expect_named(res[1], "chem01") 105 | expect_s4_class(res[c(rep(TRUE, 4), rep(FALSE, 6))], "TxpResult") 106 | expect_length(res[c(rep(TRUE, 4), rep(FALSE, 6))], 4) 107 | expect_named(res[c(rep(TRUE, 4), rep(FALSE, 6))], sprintf("chem%02d", 1:4)) 108 | expect_s4_class(res[c("chem04", "chem08")], "TxpResult") 109 | expect_length(res[c("chem04", "chem08")], 2) 110 | expect_named(res[c("chem04", "chem08")], c("chem04", "chem08")) 111 | expect_error(res[25]) 112 | expect_warning(expect_length(res[c(TRUE, FALSE)], 5)) 113 | expect_length(res["notAName"], 0) 114 | expect_silent(names(res) <- NULL) 115 | expect_error(res["hello"]) 116 | }) 117 | 118 | ##----------------------------------------------------------------------------## 119 | ## Coercion 120 | 121 | test_that("We can coerce TxpResult to data.frame", { 122 | expect_silent({ 123 | data(txp_example_input, package = "toxpiR") 124 | data(txp_example_model, package = "toxpiR") 125 | res <- txpCalculateScores(model = txp_example_model, 126 | input = txp_example_input, 127 | id.var = "name") 128 | }) 129 | expect_s3_class(as.data.frame(res), "data.frame") 130 | expect_equal(dim(as.data.frame(res)), c(10, 7)) 131 | expect_named(as.data.frame(res), 132 | c("id", "score", "rank", sprintf("s%d", 1:4))) 133 | expect_named(as.data.frame(res, 134 | id.name = "a", 135 | score.name = "b", 136 | rank.name = "c"), 137 | c("a", "b", "c", sprintf("s%d", 1:4))) 138 | txpIDs(res) <- NULL 139 | expect_warning(woID <- as.data.frame(res)) 140 | expect_s3_class(woID, "data.frame") 141 | expect_named(woID, c("score", "rank", sprintf("s%d", 1:4))) 142 | }) 143 | 144 | ##----------------------------------------------------------------------------## 145 | ## Show 146 | 147 | test_that("TxpResult show method displays correct information", { 148 | expect_silent({ 149 | data(txp_example_input, package = "toxpiR") 150 | data(txp_example_model, package = "toxpiR") 151 | res <- txpCalculateScores(model = txp_example_model, 152 | input = txp_example_input, 153 | id.var = "name") 154 | }) 155 | expect_output(print(res), "TxpResult of length 10") 156 | expect_output(print(res), "chem01 chem02 ... chem09 chem10") 157 | }) 158 | 159 | ##----------------------------------------------------------------------------## 160 | ## Plot -- TxpResult, missing 161 | 162 | test_that("We can make and edit ToxPi diagrams", { 163 | expect_silent({ 164 | data(txp_example_input, package = "toxpiR") 165 | data(txp_example_model, package = "toxpiR") 166 | res <- txpCalculateScores(model = txp_example_model, 167 | input = txp_example_input, 168 | id.var = "name") 169 | }) 170 | expect_silent(plot(res)) 171 | expect_silent(grid.edit("pie-1", fills = NULL)) 172 | grid.edit("pie-10::slice1", gp = gpar(fill = "#7DBC3D")) 173 | expect_silent(plot(res, package = "gg")) 174 | expect_silent(plot(res, package = "gg",fills = c("red","blue","green","magenta"))) 175 | expect_silent(plot(res, package = "gg",showScore = FALSE)) 176 | expect_silent(plot(res, package = "gg",ncol = 2)) 177 | expect_silent(plot(res, package = "gg",bgcolor = "white")) 178 | expect_silent(plot(res, package = "gg",sliceBorderColor = NULL)) 179 | expect_silent(plot(res, package = "gg",sliceValueColor = "#FF00FF",)) 180 | expect_silent(plot(res, package = "gg",sliceLineColor = "#FF00FF")) 181 | expect_silent(plot(res, package = "gg",showMissing = FALSE)) 182 | expect_silent(plot(res, package = "gg",showCenter = FALSE)) 183 | }) 184 | 185 | ##----------------------------------------------------------------------------## 186 | ## Plot -- TxpResult, numeric 187 | 188 | test_that("We can make ToxPi rank plot ", { 189 | expect_silent({ 190 | data(txp_example_input, package = "toxpiR") 191 | data(txp_example_model, package = "toxpiR") 192 | res <- txpCalculateScores(model = txp_example_model, 193 | input = txp_example_input, 194 | id.var = "name") 195 | }) 196 | expect_silent(plot(res, txpRanks(res))) 197 | expect_silent(plot(res, txpRanks(res), labels = 1:10)) 198 | }) 199 | 200 | 201 | --------------------------------------------------------------------------------