Nothing
get_os <- function(){
sysinf <- Sys.info()
if (!is.null(sysinf)){
os <- sysinf['sysname']
if (os == 'Darwin')
os <- "osx"
} else { ## mystery machine
os <- .Platform$OS.type
if (grepl("^darwin", R.version$os))
os <- "osx"
if (grepl("linux-gnu", R.version$os))
os <- "linux"
}
tolower(os)
}
test_that("cont vpc binless vpcstats are correct", {
skip_on_cran()
obs_data <- tidyvpc::obs_data
sim_data <- tidyvpc::sim_data
## Subest MDV = 0
obs_data <- obs_data[MDV == 0]
sim_data <- sim_data[MDV == 0]
vpc <- observed(obs_data, x = TIME, y = DV )
vpc <- simulated(vpc, sim_data, y = DV)
vpc <- binless(vpc)
vpc <- suppressWarnings(vpcstats(vpc))
os <- get_os()
if(os == "windows"){
location <-system.file("extdata/Binless","stats.csv",package="tidyvpc")
} else {
location <-system.file("extdata/Binless","stats_l.csv",package="tidyvpc")
}
stats <- fread(location, colClasses = c(qname = "factor"))
#str(stats)
#str(vpc$stats)
#Check for equality, dispatches to data.table::all.equal method
expect_equal(
vpc$stats,
stats,
tolerance = 0.003
)
})
test_that("cont vpc binless stratification vpcstats are correct", {
skip_on_cran()
obs_data <- tidyvpc::obs_data
sim_data <- tidyvpc::sim_data
## Subest MDV = 0
obs_data <- obs_data[MDV == 0]
sim_data <- sim_data[MDV == 0]
vpc <- observed(obs_data, x = TIME, y = DV )
vpc <- simulated(vpc, sim_data, y = DV)
vpc <- stratify(vpc, ~ GENDER + STUDY)
vpc <- binless(vpc)
vpc <- suppressWarnings(vpcstats(vpc))
os <- get_os()
if(os == "windows"){
location <-system.file("extdata/Binless","strat_stats.csv",package="tidyvpc")
} else {
location <-system.file("extdata/Binless","strat_stats_l.csv",package="tidyvpc")
}
stats <- fread(location, colClasses = c(qname = "factor"))
#Check for equality, dispatches to data.table::all.equal method
expect_equal(
vpc$stats,
stats,
tolerance = 0.001
)
})
test_that("cont vpc predcorrect binless vpcstats are correct", {
skip_on_cran()
obs_data <- obs_data[MDV == 0]
sim_data <- sim_data[MDV == 0 ]
sim_data <- sim_data[REP %% 2 == 1]
obs_data$PRED <- sim_data[REP == 1, PRED]
vpc <- observed(obs_data, x=TIME, y=DV)
vpc <- simulated(vpc, sim_data, y=DV)
vpc <- predcorrect(vpc, pred = PRED)
vpc <- binless(vpc)
vpc <- suppressWarnings(vpcstats(vpc))
os <- get_os()
if(os == "windows"){
location <-system.file("extdata/Binless","predcor_stats.csv",package="tidyvpc")
} else {
location <-system.file("extdata/Binless","predcor_stats_l.csv",package="tidyvpc")
}
stats <- fread(location, colClasses = c(qname = "factor"))
expect_equal(vpc$stats,
stats,
tolerance = 0.003)
})
test_that("cont vpc binless censoring vpcstats are correct", {
skip_on_cran()
obs_data <- obs_data[MDV == 0]
sim_data <- sim_data[MDV == 0]
obs_data$LLOQ <- 50
vpc <- observed(obs_data, x = TIME, y = DV )
vpc <- simulated(vpc, sim_data, y = DV)
vpc <- censoring(vpc, blq=(DV < LLOQ), lloq=LLOQ)
vpc <- binless(vpc)
vpc <- suppressWarnings(vpcstats(vpc))
expect_true(any(is.na(vpc$stats$y)))
obs_data$LLOQ <- ifelse(obs_data$GENDER == "M", 50, 25)
vpc <- observed(obs_data, x = TIME, y = DV )
vpc <- simulated(vpc, sim_data, y = DV)
vpc <- censoring(vpc, blq=(DV < LLOQ), lloq=LLOQ)
vpc <- stratify(vpc, ~ GENDER)
vpc <- binless(vpc)
vpc <- suppressWarnings(vpcstats(vpc))
expect_true(any(is.na(vpc$stats$y)) && !is.null(vpc$stats$GENDER))
})
test_that("cat vpc binless vpcstats are correct", {
skip_on_cran()
obs_cat_data <- tidyvpc::obs_cat_data
sim_cat_data <- tidyvpc::sim_cat_data
vpc <- observed(obs_cat_data, x = agemonths, y = zlencat )
vpc <- simulated(vpc, sim_cat_data, y = DV)
vpc <- binless(vpc)
vpc <- suppressWarnings(vpcstats(vpc, vpc.type = "categorical"))
location <-system.file("extdata/Binless","cat_stats.csv",package="tidyvpc")
stats <- fread(location, colClasses = c(pname = "factor"))
setkeyv(stats, c("x"))
#Check for equality, dispatches to data.table::all.equal method
expect_equal(vpc$stats, stats)
})
test_that("cat vpc binless stratification vpcstats are correct", {
skip_on_cran()
obs_cat_data <- tidyvpc::obs_cat_data
sim_cat_data <- tidyvpc::sim_cat_data
vpc <- observed(obs_cat_data, x = agemonths, y = zlencat )
vpc <- simulated(vpc, sim_cat_data, y = DV)
vpc <- stratify(vpc, ~ Country_ID_code)
vpc <- binless(vpc)
vpc <- suppressWarnings(vpcstats(vpc, vpc.type = "categorical"))
location <-system.file("extdata/Binless","cat_strat_stats.csv",package="tidyvpc")
stats <- fread(location, colClasses = c(pname = "factor"))
setkeyv(stats, c(names(vpc$strat), "x"))
#Check for equality, dispatches to data.table::all.equal method
expect_equal(vpc$stats, stats)
})
test_that("binless.tidyvpcobj returns correct errors and warnings", {
obs_data <- obs_data[MDV == 0]
sim_data <- sim_data[MDV == 0]
obs_data$PRED <- sim_data[REP == 1, PRED]
vpc <- observed(obs_data, x=TIME, y=DV)
vpc <- simulated(vpc, sim_data, y=DV)
# setting optmize = FALSE without specifying lambda or sp
expect_error(binless(vpc, optimize = FALSE),
regexp = "Set optimize = TRUE if no lambda or sp arguments specified",
fixed = TRUE)
#loess.ypc argument is deprecated
expect_warning(binless(vpc, loess.ypc = TRUE),
regexp = "The loess.ypc argument is deprecated and will be ignored. Usage of `binless()` with `predcorrect()` will now perform LOESS prediction corrected VPC by default.",
fixed = TRUE)
})
test_that("binless.tidyvpcobj uses supplied lambda and span if optimize = FALSE", {
# continuous VPC
skip_on_cran()
obs_data <- obs_data[MDV == 0]
sim_data <- sim_data[MDV == 0]
obs_data$PRED <- sim_data[REP == 1, PRED]
vpc <- observed(obs_data, x=TIME, y=DV)
vpc <- simulated(vpc, sim_data, y=DV)
vpc <- stratify(vpc, ~ GENDER)
user_lambda <- data.frame(GENDER_F = c(2,4,2), GENDER_M = c(1.9,3,2.25))
vpc <- binless(vpc, lambda = user_lambda, span = c(0.5, 0.8))
vpc <- predcorrect(vpc, pred = PRED)
expect_true(vpc$vpc.method$loess.ypc)
expect_equal(vpc$vpc.method$lambda, user_lambda)
expect_equal(vpc$vpc.method$span, c(0.5, 0.8))
vpc <- suppressWarnings(vpcstats(vpc))
expect_s3_class(vpc, "tidyvpcobj")
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.