Skip to content

Commit

Permalink
Merge pull request #1372 from adamvi/master
Browse files Browse the repository at this point in the history 
Change class comparison/checks from "identical" to "inherits" and add BASELINE tag to variables
  • Loading branch information
@adamvi
adamvi authored May 25, 2022
2 parents fbea240 + 3e90373 commit 7f10af5
Show file tree
Hide file tree
Showing 3 changed files with 18 additions and 14 deletions.
28 changes: 16 additions & 12 deletions R/studentGrowthPercentiles.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -152,7 +152,7 @@ function(panel.data, ## REQUIRED
tmp.res <- rq(method="br", ...)[['coefficients']]
} else {
tmp.res <- try(rq(method=rq.method, ...)[['coefficients']], silent=TRUE)
if ("try-error" %in% class(tmp.res)) {
if (inherits(tmp.res, "try-error")) {
tmp.res <- rq(method="br", ...)[['coefficients']]
}
}
Expand Down Expand Up @@ -200,14 +200,14 @@ function(panel.data, ## REQUIRED
if (par.start$par.type == 'MULTICORE') {
tmp.mtx <- mclapply(par.start$TAUS.LIST, function(x) eval(parse(text=paste0("rq.sgp(tmp.data[[", tmp.num.variables, "]] ~ ",
substring(mod,4), ", tau=x, data=tmp.data, my.taus=x)"))), mc.cores=par.start$workers, mc.preschedule = FALSE)
if (any(tmp.tf <- sapply(tmp.mtx, function(x) identical(class(x), "try-error")))) return(list(RQ_ERROR=sapply(which(tmp.tf), function(f) tmp.mtx[[f]][1L])))
if (any(tmp.tf <- sapply(tmp.mtx, function(x) inherits(x, "try-error")))) return(list(RQ_ERROR=sapply(which(tmp.tf), function(f) tmp.mtx[[f]][1L])))
tmp.mtx <- do.call(cbind, tmp.mtx)
}

if (par.start$par.type == 'SNOW') {
tmp.mtx <- parLapplyLB(par.start$internal.cl, par.start$TAUS.LIST, function(x) eval(parse(text=paste0("rq.sgp(tmp.data[[",
tmp.num.variables, "]] ~ ", substring(mod,4), ", tau=x, data=tmp.data, my.taus=x)"))))
if (any(tmp.tf <- sapply(tmp.mtx, function(x) identical(class(x), "try-error")))) return(list(RQ_ERROR=sapply(which(tmp.tf), function(f) tmp.mtx[[f]][1L])))
if (any(tmp.tf <- sapply(tmp.mtx, function(x) inherits(x, "try-error")))) return(list(RQ_ERROR=sapply(which(tmp.tf), function(f) tmp.mtx[[f]][1L])))
tmp.mtx <- do.call(cbind, tmp.mtx)
}
}
Expand Down Expand Up @@ -767,13 +767,13 @@ function(panel.data, ## REQUIRED
if (!(is.matrix(panel.data) || is.list(panel.data))) {
stop("Supplied panel.data not of a supported class. See help for details of supported classes")
}
if (identical(class(panel.data), "list") && !"Panel_Data" %in% names(panel.data)) {
if (inherits(panel.data, "list") && !"Panel_Data" %in% names(panel.data)) {
stop("Supplied panel.data missing Panel_Data")
}
if (identical(class(panel.data), "list") && !is.data.frame(panel.data[["Panel_Data"]])) {
if (inherits(panel.data, "list") && !is.data.frame(panel.data[["Panel_Data"]])) {
stop("Supplied panel.data$Panel_Data is not a data.frame or a data.table")
}
if (identical(class(panel.data), "list") && !is.null(panel.data[['Coefficient_Matrices']])) {
if (inherits(panel.data, "list") && !is.null(panel.data[['Coefficient_Matrices']])) {
panel.data[['Coefficient_Matrices']] <- checksplineMatrix(panel.data[['Coefficient_Matrices']])
}

Expand Down Expand Up @@ -821,7 +821,7 @@ function(panel.data, ## REQUIRED
stop("use.my.knots.boundaries must be supplied as a list or character abbreviation. See help page for details.")
}
if (is.list(use.my.knots.boundaries)) {
if (!identical(class(panel.data), "list")) {
if (!inherits(panel.data, "list")) {
stop("use.my.knots.boundaries is only appropriate when panel data is of class list. See help page for details.")
}
if (!identical(names(use.my.knots.boundaries), c("my.year", "my.subject")) &
Expand All @@ -846,7 +846,7 @@ function(panel.data, ## REQUIRED
}

if (!is.null(use.my.coefficient.matrices) && !identical(use.my.coefficient.matrices, TRUE)) {
if (!identical(class(panel.data), "list")) {
if (!inherits(panel.data, "list")) {
stop("use.my.coefficient.matrices is only appropriate when panel data is of class list. See help page for details.")
}
if (!is.list(use.my.coefficient.matrices)) {
Expand Down Expand Up @@ -1092,7 +1092,7 @@ function(panel.data, ## REQUIRED
Coefficient_Matrices <- Cutscores <- Goodness_of_Fit <- Knots_Boundaries <- Panel_Data <- SGPercentiles <- SGProjections <- Simulated_SGPs <- SGP_STANDARD_ERROR <- Verbose_Messages <- NULL
SGP_SIMEX <- SGP_SIMEX_RANKED <- SGP_NORM_GROUP_SCALE_SCORES <- SGP_NORM_GROUP_DATES <- SGP_NORM_GROUP <- NULL

if (identical(class(panel.data), "list")) {
if (inherits(panel.data, "list")) {
for (i in tmp.objects) {
if (!is.null(panel.data[[i]])) {
assign(i, panel.data[[i]])
Expand Down Expand Up @@ -1130,7 +1130,7 @@ function(panel.data, ## REQUIRED
if (is.data.frame(panel.data)) {
Panel_Data <- as.data.table(panel.data)
}
if (identical(class(panel.data), "list") && !is.data.table(panel.data[["Panel_Data"]])) {
if (inherits(panel.data, "list") && !is.data.table(panel.data[["Panel_Data"]])) {
Panel_Data <- as.data.table(panel.data[["Panel_Data"]])
}

Expand Down Expand Up @@ -1312,7 +1312,7 @@ function(panel.data, ## REQUIRED
if (is.null(content_area.progression)) {
content_area.progression <- rep(sgp.labels$my.subject, length(tmp.gp))
} else {
if (!identical(class(content_area.progression), "character")) {
if (!inherits(content_area.progression, "character")) {
stop("The 'content_area.progression' vector/argument should be a character vector. See help page for details.")
}
if (!identical(tail(content_area.progression, 1L), sgp.labels[['my.subject']])) {
Expand Down Expand Up @@ -1341,7 +1341,7 @@ function(panel.data, ## REQUIRED
year.progression <- rep("BASELINE", length(tmp.gp))
year.progression.for.norm.group <- tail(rev(yearIncrement(sgp.labels[['my.year']], c(0, -cumsum(rev(year_lags.progression))))), length(tmp.gp))
}
if (!identical(class(year.progression), "character")) {
if (!inherits(year.progression, "character")) {
stop("year.area.progression should be a character vector. See help page for details.")
}
if (!identical(sgp.labels[['my.extra.label']], "BASELINE") && !identical(tail(year.progression, 1L), sgp.labels[['my.year']])) {
Expand Down Expand Up @@ -1819,6 +1819,10 @@ function(panel.data, ## REQUIRED
if (identical(sgp.labels[['my.extra.label']], "BASELINE") && "SGP_ORDER" %in% names(quantile.data)) setnames(quantile.data, gsub("SGP_ORDER", "SGP_BASELINE_ORDER", names(quantile.data)))
if (identical(sgp.labels[['my.extra.label']], "BASELINE") && "SGP_NORM_GROUP" %in% names(quantile.data)) setnames(quantile.data, gsub("SGP_NORM_GROUP", "SGP_NORM_GROUP_BASELINE", names(quantile.data)))
if (identical(sgp.labels[['my.extra.label']], "BASELINE") && simex.tf) setnames(quantile.data, gsub("_SIMEX", "_SIMEX_BASELINE", names(quantile.data))) # SGP_SIMEX and SGP_SIMEX_RANKED
if (identical(sgp.labels[["my.extra.label"]], "BASELINE") && return.prior.scale.score) setnames(quantile.data, "SCALE_SCORE_PRIOR", "SCALE_SCORE_PRIOR_BASELINE")
if (identical(sgp.labels[["my.extra.label"]], "BASELINE") && return.prior.scale.score.standardized) setnames(quantile.data, "SCALE_SCORE_PRIOR_STANDARDIZED", "SCALE_SCORE_PRIOR_STANDARDIZED_BASELINE")
if (identical(sgp.labels[["my.extra.label"]], "BASELINE") && !is.null(percentile.cuts)) setnames(quantile.data, gsub("PERCENTILE_CUT_", "PERCENTILE_CUT_BASELINE_", names(quantile.data)))

if (identical(sgp.labels[['my.extra.label']], "EQUATED")) setnames(quantile.data, "SGP", "SGP_EQUATED")
if (identical(sgp.labels[['my.extra.label']], "EQUATED") && tf.growth.levels) setnames(quantile.data, "SGP_LEVEL", "SGP_LEVEL_EQUATED")
if (identical(sgp.labels[['my.extra.label']], "EQUATED") && "SGP_NORM_GROUP" %in% names(quantile.data)) setnames(quantile.data, gsub("SGP_NORM_GROUP", "SGP_NORM_GROUP_EQUATED", names(quantile.data)))
Expand Down
4 changes: 2 additions & 2 deletions R/studentGrowthProjections.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -518,7 +518,7 @@ function(panel.data, ## REQUIRED
if (!(all(c("Panel_Data", "Coefficient_Matrices", "Knots_Boundaries") %in% names(panel.data)))) {
stop("Supplied panel.data missing Panel_Data, Coefficient_Matrices, and/or Knots_Boundaries. See help page for details")
}
if (identical(class(panel.data[["Panel_Data"]]), "data.frame")) {
if (inherits(panel.data[["Panel_Data"]], "data.frame")) {
panel.data[["Panel_Data"]] <- as.data.table(panel.data[["Panel_Data"]])
}}

Expand Down Expand Up @@ -821,7 +821,7 @@ function(panel.data, ## REQUIRED
if (is.null(content_area.progression)) {
content_area.progression <- rep(sgp.labels[['my.subject']], length(grade.progression))
} else {
if (!identical(class(content_area.progression), "character")) {
if (!inherits(content_area.progression, "character")) {
stop("content_area.progression should be a character vector. See help page for details.")
}
if (length(content_area.progression) != length(grade.progression)) {
Expand Down
Binary file modified data/SGPstateData.rda
View file
Binary file not shown.

0 comments on commit 7f10af5

Please sign in to comment.