#' frscored_cna() #' #' @description Perform a reanalysis series on a data set and calculate the #' fit-robustness scores of the resulting solution types #' #' @param x a \code{data.frame} or \code{configTable} to be analyzed with #' \code{cna}. #' #' @param fit.range Numeric vector of length 2; determines the maximum an #' minimum values used as consistency and coverage thresholds in the #' reanalysis series. Defaults to c(1, 0.7). #' @param granularity Numeric scalar; consistency and coverage are varied by #' this value in the reanalysis series. Default 0.1. #' @param output Character vector determining whether csf's or asf's are #' extracted from the results of the analyses; "csf" (default) extracts #' csfs, "asf" asfs. #' @param scoretype Character vector specifying the scoring method: "full" #' (default, scoring is based on counting sub- and supermodels), "supermodel" #' (count supermodels) "submodel" (count submodels). #' @param normalize Character vector that determines the method used in #' normalizing the scores. "truemax" normalizes by the actual highest score #' such that the highest scoring solution types get score 1. "idealmax" #' normalizes by a theoretical maximum score calculated by assuming that #' all solutions of equal complexity are identical, and for every solution #' of a given complexity, all solutions with lower complexity are its #' submodels #' . #' @param verbose Logical; if \code{TRUE}, print additional #' information about submodel relations among the unique solution types found #' in \code{sols}. Defaults to \code{FALSE}. #' @param maxsols Integer determining the maximum number of unique solution #' types found in \code{sols} to be included in the scoring. #' @param test.model Character vector that specifies a single candidate #' \code{cna} model whose fit-robustness score is calculated against #' the results of the reanalysis series. #' @param print.all Logical, controls the number of entries printed when #' printing the results. If \code{TRUE}, results are printed as when using #' \code{print.data.frame} defaults. If \code{FALSE}, 20 highest scoring #' models are printed. #' @param ... Further arguments to \code{rean_cna} and \code{cna} #' @details \code{frscored_cna} performs a reanalysis series on a data set with all #' combinations of fit threshold values that can be generated by varying #' consistency and coverage in a given range by a constant value, determined #' respectively by arguments 'fit.range' and 'granularity', and calculates #' fr-scores for the models returned in the analyses. If a candidate model is #' provided as 'test.model', result for that model will be printed separately, #' provided the model is found in the #' reanalysis series, if not, the function stops. #' #' @examples #' library(cna) #' set.seed(6) #' dat <- cna::ct2df(cna::selectCases(cna::randomCsf(5), cna::full.ct(5))) #' res <- frscored_cna(dat) #' res #' @importFrom rlang abort #' @export frscored_cna <- function(x, fit.range = c(1, 0.7), granularity = 0.1, output = c("csf", "asf"), scoretype = c("full", "supermodel", "submodel"), normalize = c("truemax", "idealmax", "none"), verbose = FALSE, maxsols = 50, test.model = NULL, print.all = FALSE, comp.method = c("causal_submodel", "is.submodel"), n.init = 1000, ...){ if(!inherits(x, c("configTable", "data.frame","truthTab"))){ stop("invalid argument x") } cl <- match.call() dots <- list(...) if(match.arg(scoretype) != "full"){ lifecycle::deprecate_warn("0.3.0", what = "frscored_cna(scoretype)", details = "The `scoretype` argument is on its way to be removed. It is not recommended to restrict the scoring to sub- or supermodel relations only, as the scores will then not reflect the intended meaning of fit-robustness. Information about the score composition of the models can always be found by inspecting the $verbout -element of the output of `frscore()` and `frscored_cna()`.") } if (any(c("cov", "con", "con.msc") %in% names(dots))){ abort("cna arguments 'con', 'cov', 'con.msc' not meaningful") } cl$fit.range <- cl$granularity <- cl$normalize <- cl$verbose <- cl$scoretype <- cl$test.model <- cl$print.all <- cl$scoretype <- cl$maxsols <- cl$comp.method <- NULL cl[[1]] <- as.name("rean_cna") if ("ncsf" %in% names(dots)){ cl$ncsf <- dots$ncsf } attempt <- seq(max(fit.range), min(fit.range), -granularity) cl$attempt <- attempt cl$output <- match.arg(output) clres <- eval.parent(cl) rescomb <- do.call(rbind, clres) rescomb <- rescomb[!is.na(rescomb[,1]),] rescombtemp <- rescomb rescomb <- rescomb[,-c(which(names(rescomb) %in% c("cnacon", "cnacov")))] rescomb$condition <- gsub("\\),\\(", "\\)*\\(", rescomb$condition) scoretype <- match.arg(scoretype) normalize <- match.arg(normalize) if (is.null(test.model)){ scored <- frscore(rescomb$condition, normalize = normalize, verbose = verbose, scoretype = scoretype, maxsols = maxsols, comp.method = comp.method, dat = x) if(is.null(scored)){warning('no solutions found in reanalysis series, perhaps consider wider fit range \n \n') return(NULL)} } else { if(any(sapply(rescomb$condition, function(x) cna::identical.model(x, test.model)))){ scored <- frscore(rescomb$condition, normalize = normalize, verbose = verbose, scoretype = scoretype, maxsols = maxsols, comp.method = comp.method, dat = x) if(is.null(scored)){warning('no solutions found in reanalysis series, perhaps consider wider fit range \n \n') return(NULL)} } else { abort('`test.model` not found in reanalysis series') } } sc <- scored[[1]] names(sc)[names(sc) == "model"] <- "condition" rescomb$condition <- as.character(rescomb$condition) rescombXscored <- dplyr::right_join(rescomb, sc, by="condition") %>% dplyr::filter(!is.na(.data$score)) rescombXscored <- unique(rescombXscored) rescombXscored <- rescombXscored[order(rescombXscored$condition),] rescombXscored <- rescombXscored[order(rescombXscored$score, decreasing = T),] rownames(rescombXscored) <- 1:nrow(rescombXscored) if(!is.null(test.model)){ tested <- rescombXscored[sapply(rescombXscored$condition, function(x) cna::identical.model(x, test.model)),] } else { tested <- test.model } out <- structure(list(rean_models = rescombXscored, tested = tested, verbose = scored$verbose, verbout = scored$verbout, print.all = print.all, fit.range = fit.range, granularity = granularity, scoretype = scoretype, normal = normalize, rean.results = rescombtemp, maxsols = scored$maxsols, comp.method = match.arg(comp.method)), class = c("frscored_cna", "list")) return(out) } # Print method for frscored_cna() #' @export print.frscored_cna <- function(x, verbose = x$verbose, verbout = x$verbout, print.all = x$print.all, maxsols = x$maxsols, ...){ cat('FR-scored reanalysis series with fit range', x$fit.range[1], 'to', x$fit.range[2], 'with granularity', x$granularity, '\n') cat('Score type:', x$scoretype, '||', 'score normalization:', x$normal, '\n') if(maxsols$maxsols == "ignored"){ cat("no submodel checks were needed, argument 'maxsols' ignored \n") } else { cat("maxsols set to", maxsols$maxsols, "--", maxsols$excluded, "model types excluded from scoring \n\n") } cat('----- \n \n') if(!is.null(x$tested)){ cat('Candidate model tested:', x$tested$condition, '\n \n') print(x$tested) cat('\n \n') } cat('Model types: \n \n') nr <- nrow(x$rean_models) - 20L if (print.all){ print(x$rean_models) } else { print(head(x$rean_models, n = 20L)) cat('\n') if(nr > 0){ cat('...there were', nr, 'more scored model types, use \'print.all = TRUE\' to print all \n') } } if(isTRUE(verbose) & !is.null(verbose)){ cat('\n') cat('Score composition: \n') cat('----- \n') print(verbout) } invisible(x) } #' rean_cna #' #' @description Perform a reanalysis series on a data set with \code{cna} using #' all combinations of consistency and coverage threshold values in a given #' range of values #' #' @param ... Any arguments to \code{cna} except \code{con}, \code{cov} or #' \code{con.msc}, at a minimum the arxument \code{x}, a \code{data.frame} or #' a \code{configTable}. The effect of argument \code{what} will be overriden #' by \code{output}. #' #' @param attempt Numeric vector that contains the values from which #' combinations of consistency and coverage thresholds are formed, to be used #' in the analyses. #' #' @param ncsf Scalar integer, determines the maximum number of csfs calculated #' in a each \code{cna} analysis, if \code{output = "csf"}. Defaults to 20. #' #' @param output Character vector that determines whether csfs or asfs are #' returned; \code{"csf"} (default) returns csfs \code{"asf"} asfs. #' #' @returns A list, where each element is a data frame containing the results of #' a single analysis of the input data set with \code{cna}, each using a #' different combination of consistency and coverage threshold values. These #' values are added to the output as extra columns 'cnacon' and 'cnacov'. #' #' @details \code{rean_cna} performs a reanalysis series based on which #' fr-scores can be calculated output = "asf" returns asfs, output = "csf" #' csfs. #' @export #' @importFrom lifecycle deprecated rean_cna <- function(x, attempt = seq(1, 0.7, -0.1), ncsf = deprecated(), output = c("csf", "asf"), n.init = 1000, ...){ if(!inherits(x, c("configTable", "data.frame","truthTab"))){ abort(paste0("`x` should be a data frame or configuration table, not an object of type ", typeof(x))) } if(lifecycle::is_present(ncsf)){ lifecycle::deprecate_warn("0.3.0", "frscore::rean_cna(ncsf = )", "frscore::rean_cna(n.init = )") n.init <- ncsf } cl <- match.call() dots <- list(...) if (any(c("cov", "con", "con.msc") %in% names(dots))){ abort("cna arguments 'con', 'cov', 'con.msc' not meaningful") } output <- match.arg(output) cl$attempt <- cl$asf <- cl$ncsf <- cl$csf <- cl$output <- cl$n.init <- NULL cl[[1]] <- as.name("cna") cl$what <- if(output == "asf"){"a"} else {"c"} ccargs <- as.data.frame(expand.grid(attempt, attempt)) colnames(ccargs)<-c("lowfirst", "lowsec") sols <- vector("list", length = nrow(ccargs)) for (i in 1:length(sols)){ cl$con <- ccargs[i,"lowfirst"] cl$cov <- ccargs[i, "lowsec"] if (output=="csf"){sols[[i]] <- cna::csf(eval.parent(cl), n.init = n.init)} if (output=="asf"){sols[[i]] <- cna::asf(eval.parent(cl))} dt <- data.frame(cnacon = rep(cl$con, nrow(sols[[i]])), cnacov = rep(cl$cov, nrow(sols[[i]]))) sols[[i]] <- cbind(sols[[i]], dt) } return(structure(sols, class = c("rean_cna", "list"))) }