## RH 2020-07-01
#### SETUP ####
source("setup_ctrdata.R")
if (!checkSqlite()) exit_file("Reason: no SQLite")
## test function
tf <- function() {
if (Sys.info()[["sysname"]] != "Linux") {
clipr::clear_clip()
}
## database in memory
dbc <- nodbi::src_sqlite(
collection = "inmemory"
)
# register clean-up
on.exit(expr = {
try({
RSQLite::dbRemoveTable(conn = dbc$con, name = dbc$collection)
RSQLite::dbDisconnect(conn = dbc$con)
},
silent = TRUE)
}, add = TRUE)
# do tests
#### ctrLoadQueryIntoDb ####
# test
expect_error(
ctrLoadQueryIntoDb(),
"does not seem to result")
tmpdf <- iris[1:5, ]
names(tmpdf) <- paste0("query-", names(tmpdf))
# test
expect_error(
suppressWarnings(
ctrLoadQueryIntoDb(
queryterm = tmpdf)),
"has to be a non-empty string")
# test
expect_error(
suppressWarnings(
ctrLoadQueryIntoDb(
queryterm = tmpdf,
querytoupdate = 1L,
con = dbc)),
"only one of 'queryterm' and 'querytoupdate'")
tmpdf["query-term"] <- as.character(tmpdf[["query-Species"]])
# test
expect_error(
suppressWarnings(
ctrLoadQueryIntoDb(
queryterm = tmpdf)),
"'register' has to be a non-empty string")
# test
expect_error(
ctrLoadQueryIntoDb(
queryterm = iris),
"'queryterm' does not seem to result from ctr")
# test
expect_error(
suppressWarnings(
ctrLoadQueryIntoDb(
queryterm = "https\\#@")),
"'queryterm' does not seem to result from")
# test
expect_error(
suppressMessages(
ctrLoadQueryIntoDb(
queryterm = "https://classic.clinicaltrials.gov/this*")),
"'queryterm' has unexpected characters")
# test
expect_error(
suppressWarnings(
ctrLoadQueryIntoDb(
queryterm = "something",
register = "unknown")),
"'queryterm' does not seem to result from")
# test no history or no table with
# the name specified in dbc
expect_error(
suppressWarnings(
suppressMessages(
ctrLoadQueryIntoDb(
querytoupdate = 1L,
con = dbc))))
# test clipr - was not able to get
# testing to work on linux containers
if (.Platform$OS.type == "windows" ||
grepl("darwin", sessionInfo()$platform,
ignore.case = TRUE)) {
tmpcb <- suppressWarnings(
clipr::read_clip(
allow_non_interactive = TRUE)
)
# no testing if some content is
# found in the system clipboard
if (!is.null(tmpcb) && length(tmpcb) == 1L && tmpcb == "") {
expect_error(
suppressWarnings(
suppressMessages(
ctrLoadQueryIntoDb(
queryterm = "",
con = dbc))),
"Cannot use 'queryterm' ")
}
}
# test
expect_error(
suppressWarnings(
ctrLoadQueryIntoDb(
querytoupdate = pi,
con = dbc)))
# test
expect_error(
suppressWarnings(
ctrLoadQueryIntoDb(
querytoupdate = "notlast",
con = dbc)))
# this also checks only.count
# and that no records were found
expect_error(
suppressWarnings(
ctrLoadQueryIntoDb(
queryterm = "someQueryForErrorTriggering",
querytoupdate = 1L,
only.count = TRUE,
con = dbc)),
"only one of 'queryterm' and 'querytoupdate'")
#### database ####
# test
expect_error(
ctrdata:::ctrDb(
con = NULL
), "specify in parameter 'con' a database connection")
# test if database connection
# is opened by ctrDb
RSQLite::dbDisconnect(conn = dbc$con)
# test
expect_error(
suppressMessages(
suppressWarnings(
dbFindIdsUniqueTrials(
con = dbc))),
"No records found, check collection")
# test
expect_true(grepl("inmemory", dbc$collection))
# sqlite but no collection specified
dbc <- try(nodbi::src_sqlite(), silent = TRUE)
# register clean-up
on.exit(expr = {
try({
RSQLite::dbRemoveTable(conn = dbc$con, name = dbc$collection)
RSQLite::dbDisconnect(conn = dbc$con)
},
silent = TRUE)
}, add = TRUE)
out <- inherits(dbc, c("src_sqlite", "docdb_src"))
if (out) {
# test
expect_error(
suppressMessages(
suppressWarnings(
dbFindIdsUniqueTrials(
con = dbc))),
"parameter .* table")
RSQLite::dbDisconnect(conn = dbc$con)
}
rm(dbc, out)
# postgres but no collection specified
dbc <- try(nodbi::src_postgres(), silent = TRUE)
# register clean-up
on.exit(expr = {
try({
RPostgres::dbRemoveTable(conn = dbc$con, name = dbc$collection)
RPostgres::dbDisconnect(conn = dbc$con)
},
silent = TRUE)
}, add = TRUE)
out <- inherits(dbc, c("src_postgres", "docdb_src"))
if (out) {
# test
expect_error(
suppressMessages(
suppressWarnings(
dbFindIdsUniqueTrials(
con = dbc))),
"pecify .* table")
RPostgres::dbDisconnect(conn = dbc$con)
}
rm(dbc, out)
#### ctrGetQueryUrl ####
# see also test_ctrdata_other_functions.R
# EUCTR mangling: list of c(input, expected output)
queryterms <- list(
c("cancer&age=adult", # add query=
"query=cancer&age=adult"),
c("cancer", # add query=
"query=cancer"),
c("cancer+AND breast&age=adult&phase=0", # add query=
"query=cancer+AND breast&age=adult&phase=0"),
c("cancer&age=adult&phase=0", # add query=
"query=cancer&age=adult&phase=0"),
c("cancer&age=adult&phase=1&results=true", # add query=
"query=cancer&age=adult&phase=1&results=true"),
c("&age=adult&phase=1&abc=xyz&cancer&results=true", # insert query=
"&age=adult&phase=1&abc=xyz&query=cancer&results=true"),
c("age=adult&cancer", # insert query=
"age=adult&query=cancer"),
c("2010-024264-18", # add query=
"query=2010-024264-18"),
c("NCT1234567890", # add query=
"query=NCT1234567890"),
c("teratoid&country=dk", # add query=
"query=teratoid&country=dk"),
c("term=cancer&age=adult", # keep
"term=cancer&age=adult"),
c("age=adult&term=cancer", # keep
"age=adult&term=cancer")
)
# sapply(sapply(queryterms, "[[", 1),
# function(i) ctrGetQueryUrl(url = i, register = "EUCTR")[["query-term"]],
# USE.NAMES = FALSE, simplify = TRUE)
# test
expect_true(all(
vapply(queryterms, function(qt) {
suppressMessages(ctrGetQueryUrl(
url = qt[[1]],
register = "EUCTR"))[[1]] == qt[[2]]},
logical(1L))
))
# CTGOV
queryterms <- list(
c("cancer&age=adult", # add term=
"term=cancer&age=adult"),
c("cancer", # add term=
"term=cancer"),
c("cancer&age=adult&phase=0", # add term=
"term=cancer&age=adult&phase=0"),
c("cancer&age=adult&phase=1&results=true", # add term=
"term=cancer&age=adult&phase=1&results=true"),
c("&age=adult&phase=1&abc=xyz&cancer&results=true", # add term=
"&age=adult&phase=1&abc=xyz&term=cancer&results=true"),
c("age=adult&cancer", # add term=
"age=adult&term=cancer"),
c("2010-024264-18", # add term=
"term=2010-024264-18"),
c("NCT1234567890", # add term=
"term=NCT1234567890"),
c("NCT1234567890+OR+NCT1234567890+AND+SOMETHING", # add term=
"term=NCT1234567890+OR+NCT1234567890+AND+SOMETHING"),
c("term=cancer&age=adult", # no change
"term=cancer&age=adult"),
c("age=adult&term=cancer", # no change
"age=adult&term=cancer"))
# sapply(sapply(queryterms, "[[", 1),
# function(i) ctrGetQueryUrl(url = i, register = "CTGOV")[["query-term"]],
# USE.NAMES = FALSE, simplify = TRUE)
# test
expect_true(all(
vapply(queryterms, function(qt) {
suppressMessages(ctrGetQueryUrl(
url = qt[[1]],
register = "CTGOV"))[[1]] == qt[[2]]},
logical(1L))
))
# URLs
queryurls <- list(
# euctr
c("https://www.clinicaltrialsregister.eu/ctr-search/search?query=neuroblastoma",
"query=neuroblastoma"),
c("https://www.clinicaltrialsregister.eu/ctr-search/trial/2019-003713-33/NL",
"query=2019-003713-33"),
c("https://www.clinicaltrialsregister.eu/ctr-search/trial/2007-000371-42/results",
"query=2007-000371-42"),
# ctgov
c("https://classic.clinicaltrials.gov/ct2/results?cond=Neuroblastoma&term=&intr=Investigational+Agent&type=Intr",
"cond=Neuroblastoma&intr=Investigational+Agent&type=Intr"),
c("https://classic.clinicaltrials.gov/ct2/show/NCT01492673?type=Intr&cond=Neuroblastoma&intr=Investigational+Agent&draw=2&rank=1",
"term=NCT01492673"),
c("https://classic.clinicaltrials.gov/ct2/show/NCT01492673",
"term=NCT01492673"),
# isrctn
c("https://www.isrctn.com/search?q=neuroblastoma&searchType=advanced-search",
"q=neuroblastoma"),
c("https://www.isrctn.com/search?q=&filters=condition:cancer",
"q=&filters=condition:cancer"),
c("https://www.isrctn.com/search?q=&filters=condition%3Acancer%2CrecruitmentCountry%3AGermany&searchType=basic-search",
"q=&filters=condition:cancer,recruitmentCountry:Germany"),
c("https://www.isrctn.com/ISRCTN70039829",
"q=ISRCTN70039829")
)
# sapply(sapply(queryurls, "[[", 1),
# function(i) ctrGetQueryUrl(url = i)[["query-term"]],
# USE.NAMES = FALSE, simplify = TRUE)
# test
expect_true(all(
vapply(queryurls, function(qt) {
suppressMessages(ctrGetQueryUrl(
url = qt[[1]]))[[1]] == qt[[2]]},
logical(1L))
))
#### clipboard ####
if (Sys.info()[["sysname"]] != "Linux") {
clipr::clear_clip()
clipr::write_clip(
queryurls[[1]][1],
allow_non_interactive = TRUE)
expect_message(
tmp <- ctrGetQueryUrl(),
"Found search query")
expect_true(is.data.frame(tmp))
expect_equal(tmp[["query-term"]], queryurls[[1]][2])
rm(tmp)
clipr::write_clip(
"NotARegisterUrl",
allow_non_interactive = TRUE)
expect_error(
ctrGetQueryUrl(),
"no clinical trial register")
}
# URLs for single studies
queryurls <- list(
# euctr
c("https://www.clinicaltrialsregister.eu/ctr-search/trial/2007-000371-42/results",
"https://www.clinicaltrialsregister.eu/ctr-search/search?query=2007-000371-42#tabs"),
# ctgov classic
c("https://classic.clinicaltrials.gov/ct2/show/NCT01492673?cond=neuroblastoma",
"https://classic.clinicaltrials.gov/ct2/show/NCT01492673"),
# ctgov classic
c("https://clinicaltrials.gov/ct2/show/NCT01492673?cond=neuroblastoma",
"https://classic.clinicaltrials.gov/ct2/show/NCT01492673"),
# ctgov2
c("https://www.clinicaltrials.gov/study/NCT01467986?cond=neuroblastoma&intr=Investigational%20drug&aggFilters=ages:child",
"https://www.clinicaltrials.gov/study/NCT01467986#main-content"),
# isrctn
c("https://www.isrctn.com/ISRCTN70039829",
"https://www.isrctn.com/ISRCTN70039829"),
# isrctn
c("https://www.isrctn.com/ISRCTN61139514?q=&filters=condition:cancer",
"https://www.isrctn.com/ISRCTN61139514")
)
# sapply(sapply(queryurls, "[[", 1),
# function(i) ctrOpenSearchPagesInBrowser(url = i),
# USE.NAMES = FALSE, simplify = TRUE)
# test
expect_true(all(
vapply(queryurls, function(qt) {
suppressMessages(ctrOpenSearchPagesInBrowser(
url = qt[[1]]))[[1]] == qt[[2]]},
logical(1L))
))
# clean up
rm(queryurls)
} # tf test function
tf()
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.