acepack/0000755000176200001440000000000014753301542011645 5ustar liggesusersacepack/tests/0000755000176200001440000000000014744022052013003 5ustar liggesusersacepack/tests/testthat/0000755000176200001440000000000014753301542014647 5ustar liggesusersacepack/tests/testthat/test_ace.R0000644000176200001440000000464314753164247016601 0ustar liggesuserscontext("ACE Transform") set.seed(1) # For repeatability x <- matrix(runif(500)*2 - 1, ncol=5) e <- rnorm(100) y <- log(4 + sin(4*x[,1]) + abs(x[,2]) + x[,3]^2 + + x[,4]^3 + x[,5] + 0.1*e) # D. Wang, Murphy M,. Estimating Optimal Transformations for Multiple # Regression Using the ACE Algorithm. # Journal of Data Science 2(2004), 329-346. test_that("Estimates Multiple Transformations", { y <- log(4 + sin(4*x[,1]) + abs(x[,2]) + x[,3]^2 + x[,4]^3 + x[,5] + 0.1*e) expect_no_error(model <- ace(x, y)) # Linear offset were computed using lm expect_true(max(sin(4*x[,1]) - model$tx[,1] - 0.003874) < 0.1) expect_true(max(abs(x[,2]) - model$tx[,2] - 0.481000) < 0.1) expect_true(max(x[,3]^2 - model$tx[,3] - 0.321443) < 0.1) expect_true(max(x[,4]^3 - model$tx[,4] - 0.039418) < 0.12) expect_true(max(x[,5] - model$tx[,5] - 0.008231) < 0.1) }) test_that("Estimates Multiple Transformations Specified via Formula", { expect_no_error(model <- ace(y~x[,1]+x[,2]+x[,3]+x[,4]+x[,5])) # Linear offset were computed using lm expect_true(max(sin(4*x[,1]) - model$tx[,1] - 0.003874) < 0.1) expect_true(max(abs(x[,2]) - model$tx[,2] - 0.481000) < 0.1) expect_true(max(x[,3]^2 - model$tx[,3] - 0.321443) < 0.1) expect_true(max(x[,4]^3 - model$tx[,4] - 0.039418) < 0.12) expect_true(max(x[,5] - model$tx[,5] - 0.008231) < 0.1) expect_no_error( model <- ace(y~x1+x2+x3+x4+x5, data.frame(x1=x[,1], x2=x[,2], x3=x[,3], x4=x[,4], x5=x[,5]))) # Linear offset were computed using lm expect_true(max(sin(4*x[,1]) - model$tx[,1] - 0.003874) < 0.1) expect_true(max(abs(x[,2]) - model$tx[,2] - 0.481000) < 0.1) expect_true(max(x[,3]^2 - model$tx[,3] - 0.321443) < 0.1) expect_true(max(x[,4]^3 - model$tx[,4] - 0.039418) < 0.12) expect_true(max(x[,5] - model$tx[,5] - 0.008231) < 0.1) }) test_that("Handles categorical properly", { y <- rnorm(100) x <- sample(1:3, 100, replace=TRUE) expect_no_error(result <- ace(x, y, cat=1)) expect_equal(result$ierr, 0) expect_warning(ace(rep(1, 100), y, cat=1), "no variance") expect_warning(ace(x, rep(1, 100), cat=0), "no variance") }) test_that("Will stop on error if specified", { expect_error(ace(rep(1, 100), rnorm(100), cat=1, on.error=stop), "no variance") })acepack/tests/testthat/test_avas.R0000644000176200001440000000144614744022052016764 0ustar liggesuserscontext("AVAS") test_that("AVAS Creates finite output", { set.seed(1) x <- runif(200,0,2*pi) y <- exp(sin(x)+rnorm(200)/2) a <- avas(x,y) expect_true(all(is.finite(a$tx))) }) test_that("Estimates Multiple Transformations", { set.seed(2) # For repeatability x <- matrix(runif(500)*2 - 1, ncol=5) e <- rnorm(100) y <- log(4 + sin(4*x[,1]) + abs(x[,2]) + x[,3]^2 + + x[,4]^3 + x[,5] + 0.1*e) model <- avas(x, y) expect_equal(max(sin(4*x[,1]) - model$tx[,1]), 0.09213036, tol=1e-7) expect_equal(max(abs(x[,2]) - model$tx[,2]), 0.6359979, tol=1e-7) expect_equal(max(x[,3]^2 - model$tx[,3]), 0.4453127, tol=1e-7) expect_equal(max(x[,4]^3 - model$tx[,4]), 0.1625947, tol=1e-7) expect_equal(max(x[,5] - model$tx[,5]), 0.1094684, tol=1e-7) })acepack/tests/testthat/test_ace_test.R0000644000176200001440000000440114753154167017630 0ustar liggesuserscontext("ACE Permutation Test (acetest)") set.seed(1) n <- 200 x <- matrix(rnorm(n*2), n) nu <- 2 d200 <- x / sqrt(rchisq(n, nu)/nu) #multivariate t set.seed(1) n <- 5 x <- matrix(rnorm(n*2), n) nu <- 2 d5 <- x / sqrt(rchisq(n, nu)/nu) #multivariate t test_that("Repeats known results for n=200", { expect_no_error(x <- acetest(d200)) expect_equal(x$n, 999) expect_equal(x$ace, 0.5614263, tolerance=1e-6) expect_equal(x$pval, 0.001, tolerance=1e-6) }) test_that("Repeats known results for n=5", { expect_no_error(x <- acetest(d5)) expect_equal(x$n, 120) expect_equal(x$ace, 0.1809508, tolerance=1e-6) expect_equal(x$pval, 0.8347107, tolerance=1e-6) }) test_that("Pulls variable names", { joe <- d5[,1] jim <- d5[,2] expect_no_error(x <- acetest(joe, jim)) expect_equal(x$xname, "joe") expect_equal(x$yname, "jim") }) test_that("Pulls matrix names", { zed <- d5 colnames(zed) <- c("sue", "bev") expect_no_error(x <- acetest(zed)) expect_equal(x$xname, "sue") expect_equal(x$yname, "bev") }) test_that("Pulls data.frame names", { zed <- as.data.frame(d5) names(zed) <- c("sam", "pat") expect_no_error(x <- acetest(zed)) expect_equal(x$xname, "sam") expect_equal(x$yname, "pat") }) test_that("Accepts data.frame", { expect_no_error(x <- acetest(as.data.frame(d5))) expect_equal(x$n, 120) expect_equal(x$xname, 'V1') }) test_that("Errors if matrix is not 2 columns.", { expect_error(acetest(matrix(1:9, ncol=3)), 'must be 2 columns') expect_error(acetest(matrix(1:9, ncol=1)), 'must be 2 columns') }) test_that("Cannot have a matrix 'x' and a y specified", { expect_error(acetest(matrix(1:8, ncol=2), 1:10), "Cannot have a matrix for 'x' and provide 'y'") }) test_that("When x is not a matrix must have a y", { expect_error(acetest(1:4), "Must supply both 'x' and 'y'") }) test_that("'nperm' must be a positive integer", { expect_error(acetest(1:4, 5:8, nperm=-1), "'nperm' must be a positive integer") expect_error(acetest(1:4, 5:8, nperm='r'), "'nperm' must be a positive integer") expect_error(acetest(1:4, 5:8, nperm=2:3), "'nperm' must be a positive integer") }) test_that("Length of 'x' and 'y' must be the same", { expect_error(acetest(1:2, 5:10), "Length of 'x' and 'y' must be the same") }) acepack/tests/testthat/test_bullseye.R0000644000176200001440000000076014744022052017654 0ustar liggesuserscontext("pair test from bullseye") ace_cor <- function(x,y,handle.na=TRUE) { if(handle.na){ pick <- complete.cases(x, y) x <- x[pick] y <- y[pick] } cat <- NULL if (is.factor(x)){ x <- as.numeric(x) cat <- 1 } if (is.factor(y)) { y <- as.numeric(y) cat <- c(cat,0) } acepack::ace(x,y, cat=cat) } test_that("ace_cor works", { expect_no_error(results <- ace_cor(iris$Sepal.Length, iris$Species)) expect_equal(results$rsq, 0.7027773, tol=1e-6) }) acepack/tests/testthat.R0000644000176200001440000000007214313242702014763 0ustar liggesuserslibrary(testthat) library(acepack) test_check("acepack") acepack/MD50000644000176200001440000000343114753301542012156 0ustar liggesusersbd67e04701080bfb339af10b996bc79f *DESCRIPTION cdb51e219e72a1c25b91ae23abfdafeb *LICENSE 5b73aa3bedad3ee3259a57fef9975d4a *LICENSE.note e84775eff0b8c38f34989730deab82d0 *NAMESPACE 6d548a9cb1d5b2e749a092ecf305392e *NEWS.md 77607f50cf621e397d2c3bb315a5d0e1 *R/ace.R 2a06b51fa58db33003ef454d5eac4266 *R/acetest.R 0263e582b1eba9458fe7f4c37c30b8ee *R/avas.R ad0f1a3f75279667bbd13bdb3f504868 *R/set_control.R f96dfc39974328f9dbb8f1b03ab5c0cd *README.md 78f070a760d3dd610cd8e6cd958ec945 *man/ace.Rd 176fea6ea6663b64ff483438a6bb8852 *man/ace.test.Rd ddbd950058ec74de6c085f00dd680f91 *man/avas.Rd 58d777b0155020d91dffa553f0d348e2 *man/set_control.Rd 249ab9fc34b8a10cce665ce9c63b8361 *src/Makevars fdb3def34cf3cf2bf6da6a8e2c8ba02d *src/acedata.f90 40466d42a1e9f11c05617a95c9f7f78e *src/acemod.f90 cf36f35ca60a755aefacbd9d5efd6f02 *src/bakfit.f90 7f3a2275518380b8faabfde2b4e0068b *src/calcmu.f90 e9242ea88e208020f7f1ffdcb187c726 *src/ctsub.f90 399f3a1bb7822c708725899ee9adc806 *src/favas.f90 256adb8e7011a0e334c175e50ed20e39 *src/init.c c41d6adc3be0f20d54b6c89787ef8583 *src/mace.f90 af1a80a1e9c4a09434de04827b36317b *src/model.f90 3b1ebb6eb0c73756840dce27afd75258 *src/montne.f90 1307750cd2474a02dd2e5bf53df9e720 *src/rlsmo.f90 7ee9a8cabbe6cc0f865b56184033d764 *src/scail.f90 9e7b1488dfe8a5c0dee908ed391d0b7a *src/smooth.f90 b139dbb4a3e86bdc4209276fbbd1272d *src/smothr.f90 448bcfd7d45626745b5e3c60d0bd2329 *src/sort.f90 43b57d2d6c0ebf679b859b53d6a23066 *src/supersmoother.f90 53bb76750a51c2161968a92d97a28a1d *src/supsmu.f90 77ab40a84bd0555dd42223b3404430c3 *tests/testthat.R aef1209bba454486851a83fafa58f76b *tests/testthat/test_ace.R 2de14f0b3767ca70756c5fa0fe85acfe *tests/testthat/test_ace_test.R 1d0b8698c76ecd08ae9e0095c9055025 *tests/testthat/test_avas.R 40c445eaa2484e0aa2bb8deef8acb94a *tests/testthat/test_bullseye.R acepack/R/0000755000176200001440000000000014753165207012054 5ustar liggesusersacepack/R/acetest.R0000644000176200001440000001633114753135631013631 0ustar liggesusers ############################################################################# # # This file is part of acepack. # # Copyright 2024,2025 Hajo Holzmann, Bernhard Klar # Copyright 2025 Shawn Garbett (edits and extensions) # # Permission to use, copy, modify, distribute, and sell this software and # its documentation for any purpose is hereby granted without fee, # provided that the above copyright notice appear in all copies and that # both that copyright notice and this permission notice appear in # supporting documentation. No representations are made about the # suitability of this software for any purpose. It is provided "as is" # without express or implied warranty. ############################################################################### permn <- function(x, fun = NULL, ...) { # DATE WRITTEN: 23 Dec 1997 LAST REVISED: 23 Dec 1997 # AUTHOR: Scott D. Chasalow (Scott.Chasalow@users.pv.wau.nl) # # DESCRIPTION: # Generates all permutations of the elements of x, in a minimal- # change order. If x is a positive integer, returns all permutations # of the elements of seq(x). If argument "fun" is not null, applies # a function given by the argument to each point. "..." are passed # unchanged to the function given by argument fun, if any. # # Returns a list; each component is either a permutation, or the # results of applying fun to a permutation. # # REFERENCE: # Reingold, E.M., Nievergelt, J., Deo, N. (1977) Combinatorial # Algorithms: Theory and Practice. NJ: Prentice-Hall. pg. 170. # # SEE ALSO: # sample, fact, combn, hcube, xsimplex # # EXAMPLE: # # Convert output to a matrix of dim c(6, 720) # t(array(unlist(permn(6)), dim = c(6, gamma(7)))) # # # A check that every element occurs the same number of times in each # # position # apply(t(array(unlist(permn(6)), dim = c(6, gamma(7)))), 2, tabulate, # nbins = 6) # # # Apply, on the fly, the diff function to every permutation # t(array(unlist(permn(6, diff)), dim = c(5, gamma(7)))) # if(is.numeric(x) && length(x) == 1 && x > 0 && trunc(x) == x) x <- seq( x) n <- length(x) nofun <- is.null(fun) out <- vector("list", gamma(n + 1)) p <- ip <- seqn <- 1:n d <- rep(-1, n) d[1] <- 0 m <- n + 1 p <- c(m, p, m) i <- 1 use <- - c(1, n + 2) while(m != 1) { out[[i]] <- if(nofun) x[p[use]] else fun(x[p[use]], ...) i <- i + 1 m <- n chk <- (p[ip + d + 1] > seqn) m <- max(seqn[!chk]) if(m < n) d[(m + 1):n] <- - d[(m + 1):n] index1 <- ip[m] + 1 index2 <- p[index1] <- p[index1 + d[m]] p[index1 + d[m]] <- m tmp <- ip[index2] ip[index2] <- ip[m] ip[m] <- tmp } out } #' @name acetest #' @title ACE permutation test of independence #' @description Performs a permutation test of independence or association. The #' alternative hypothesis is that x and y are dependent. #' #' Code authored by Bernhard Klar, Shawn Garbett. #' @param x a numeric vector, or a matrix or data frame with two columns. The #' first column is the 'y' and the second column is the 'x' when #' calling \code{\link{ace}}. #' @param y a vector with same length as x. Default is NULL. #' @param nperm number of permutations. Default is 999. #' @param object S3 object of test results to dispatch. #' @param digits Number of significant digits to round for summary. #' @param acol for plot; color of the point estimate of correlation #' @param xlim for plot;xlimit of histogram #' @param col for plot;color of histogram bars #' @param breaks for plot;number of breaks. Default to 100. #' @param main for plot; main title of plot #' @param xlab for plot; x-axis label #' @param lwd for plot; line width of point estimate #' @param ... additional arguments to pass to \code{cor}. #' @seealso \code{\link{cor}} #' @return a list containing the following: #' \itemize{ #' \item{\code{ace}} The value of the test statistic. #' \item{\code{pval}} The *p*-value of the test. #' } #' @references #' Holzmann, H., Klar, B. 2025. "Lancaster correlation - a new dependence measure #' linked to maximum correlation". Scandinavian Journal of Statistics. #' 52(1):145-169 #' @importFrom stats cor #' @export #' @rdname ace.test #' @examples #' #' n <- 200 #' z <- matrix(rnorm(2*n), n) / sqrt(rchisq(n, 2)/2) #' x <- z[,2]; y <- z[,1] #' cor.test(x, y, method="spearman") #' acetest(x, y) #' #' plot(acetest(z)) acetest <- function(x, y = NULL, nperm = 999, ...) { if(is.data.frame(x)) x <- as.matrix(x) # Check user supplied parameters if (is.matrix(x) ) { if (ncol(x) != 2) stop("Matrix 'x' must be 2 columns.") if (!is.null(y)) stop("Cannot have a matrix for 'x' and provide 'y'.") } else # x is not a matrix { if (is.null(y)) stop("Must supply both 'x' and 'y' or a 2 column matrix 'x'.") } if (!is.numeric(nperm) || nperm[1] <= 0 || length(nperm) != 1) stop("'nperm' must be a positive integer.") if (!is.null(y) && length(x) != length(y)) stop("Length of 'x' and 'y' must be the same.") # Extract variable names xname <- as.character(substitute(x)) yname <- as.character(substitute(y)) if (is.matrix(x)) { nm <- colnames(x) y = x[,2] x = x[,1] if(!is.null(nm)) { xname <- nm[1] yname <- nm[2] } } if(is.null(yname) || identical(yname, character(0)) || yname == '') yname <- 'y' # Do the alternative hypothesis estimate a <- ace(x, y) ace.cor <- as.vector( cor(a$tx, a$ty, ...) ) n <- factorial(length(x)) if (n <= nperm) # Use all permutations { nperm <- n perm <- permn(x) exact <- TRUE tp <- vapply( 1:nperm, function(i) { a <- ace(perm[[i]],y) cor(a$tx[,1], a$ty, ...) }, numeric(1)) } else # Only do a bootstrap approximation { exact <- FALSE tp <- sapply(1:nperm, function(i) { a <- ace(sample(x),y) cor(a$tx[,1], a$ty, ...) }) } pval <- (sum(tp > ace.cor) + 1) / (nperm + 1) structure( list(ace = ace.cor, pval = pval, exact=exact, n=nperm, tp = tp, xname=xname, yname=yname), class=c("acetest", "list")) } #' @rdname ace.test #' @export summary.acetest <- function(object, ..., digits) { object$ace <- signif(object$ace, digits) object$pval <- signif(object$pval, digits) object } #' @rdname ace.test #' @export print.acetest <- function(x, ...) { if(x$exact) { cat("\nACE Exact Permutation Test of Independence\n", ...) } else { cat("\nACE Approximate Permutation Test of Independence\n", ...) } cat('\nalternative hypothesis:',x$xname,'and', x$yname, 'are dependent\n', ...) cat("Ace correlation \u03c1 =", x$ace, "\n", ...) pval <- format(x$pval, scientific=if(x$pval < 0.0001) TRUE else FALSE) if(1/(x$n+1) == x$pval) { cat("p-value <", pval, "\n", ...) } else { cat("p-value =", pval, "\n", ...) } cat("\n", ...) invisible(x) } #' @importFrom graphics hist #' @importFrom graphics abline #' @export #' @rdname ace.test plot.acetest <- function( x, acol='blue', xlim=c(min(x$tp),max(c(x$tp, ceiling(x$ace*10)/10))), col='black', breaks=100, main='ACE Correlation Permutations', xlab=bquote(rho(.(x$xname),.(x$yname))), lwd=2, ...) { hist(x$tp, xlim=xlim, col=col, breaks=breaks, main=main, xlab=xlab, ...) abline(v=x$ace, col=acol, lwd=lwd) invisible() }acepack/R/set_control.R0000644000176200001440000001225214753135631014532 0ustar liggesusers ############################################################################# # # This file is part of acepack. # # Copyright 1985,2007 Jerome H. Friedman # Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center # # Permission to use, copy, modify, distribute, and sell this software and # its documentation for any purpose is hereby granted without fee, # provided that the above copyright notice appear in all copies and that # both that copyright notice and this permission notice appear in # supporting documentation. No representations are made about the # suitability of this software for any purpose. It is provided "as is" # without express or implied warranty. ############################################################################### #' @name set_control #' @title Set internal parameters that control ACE and AVAS algorithms #' #' @param alpha numeric(1); AVAS; Controls high frequency (small span) penalty #' used with automatic span selection (base tone control). An #' alpha < 0.0 or alpha > 10.0 results in no effect. Default is 5.0. #' @param big numeric(1); ACE and AVAS; a large floating point number. #' Default is 1.0e30. #' @param sml numeric(1); AVAS; A small number. Should be set so that `(sml)**(10.0)` #' does not cause floating point underflow. Default is 1e-30. #' @param span numeric(1); ACE and AVAS; Span to use in smoothing represents the #' fraction of observations in smoothing window. Automatic span selection #' is performed if set to 0.0. Default is 0.0 (automatic). #' #' For small samples (n < 40) or if there are substantial serial #' correlations between observations close in x - value, then #' a specified fixed span smoother (span > 0) should be #' used. Reasonable span values are 0.3 to 0.5. #' @param spans numeric(3); AVAS; span values for the three running linear smoothers. #' \describe{ #' \item{"spans(1)"}{Tweeter span. Default is 0.05.} #' \item{"spans(2)"}{Midrange span. Default is 0.2.} #' \item{"spans(3)"}{Woofer span. Default is 0.5.} #' } #' Warning: These span values should be changed only with great care. #' @param eps numeric(1); AVAS; Used to numerically stabilize slope calculations #' for running linear fits. #' @param maxit integer(1); ACE and AVAS; Maximum number of iterations. #' Default is 20. #' @param nterm integer(1); ACE and AVAS; Number of consecutive iterations for #' which rsq must change less than delcor for convergence. Default is 3. #' @return NULL #' @description #' #' These parameters are used in the smoothing routines of ACE and AVAS. ACE and #' AVAS both have their own smoothing implementations. This sets them globally #' for the package. #' #' The default values are good for the vast majority of cases. This routine #' is included to provide complete control to the user, but is rarely needed. #' #' @examples #' set_control(maxit=40) #' set_control(maxit=20) #' set_control(alpha=5.0) #' set_control(big=1e30, sml=1e-30) #' set_control(eps=1e-3) #' set_control(span=0.0, spans=c(0.05, 0.2, 0.5)) #' set_control(maxit=20, nterm=3) #' @export set_control <- function(alpha=NULL, big =NULL, span =NULL, sml =NULL, eps =NULL, spans=NULL, maxit=NULL, nterm=NULL) { if(!is.null(alpha)) { if(!inherits(alpha, "numeric") || length(alpha) != 1) stop("Misspecified alpha. Must be numeric(1).") if(alpha < 0.0 || alpha > 10.0) warning("Alpha outside of {0,10} skips use of parameter.") mode(alpha) <- "double" .Fortran("set_alpha", a=alpha, PACKAGE = "acepack") } if(!is.null(big)) { if(!inherits(big, "numeric") || length(big) != 1) stop("Misspecified big. Must be numeric(1)") mode(big) <- "double" .Fortran("set_big",b=big, PACKAGE = "acepack") } if(!is.null(span)) { if(!inherits(span, "numeric") || length(span) != 1) stop("Misspecified span. Must be numeric(1)") mode(span) <- "double" .Fortran("set_span",s=span, PACKAGE = "acepack") } if(!is.null(sml)) { if(!inherits(sml, "numeric") || length(sml) != 1) stop("Misspecified sml. Must be numeric(1)") mode(sml) <- "double" .Fortran("set_sml",s=sml, PACKAGE = "acepack") } if(!is.null(eps)) { if(!inherits(eps, "numeric") || length(eps) != 1) stop("Misspecified eps. Must be numeric(1)") mode(eps) <- "double" .Fortran("set_eps",e=eps, PACKAGE = "acepack") } if(!is.null(spans)) { if(!inherits(spans, "numeric") || length(spans) != 3) stop("Misspecified spans. Must be numeric(3)") mode(spans) <- "double" .Fortran("set_spans",sps=spans, PACKAGE = "acepack") } if(!is.null(maxit)) { if(!inherits(maxit, "numeric") || length(maxit) != 1) stop("Misspecified maxit. Must be numeric(1)") if(maxit <= 0) stop("Misspecified maxit. Must be larger than 0") .Fortran("set_maxit",m=as.integer(maxit), PACKAGE = "acepack") } if(!is.null(nterm)) { if(!inherits(nterm, "numeric") || length(nterm) != 1) stop("Misspecified nterm. Must be numeric(1)") if(nterm <= 0) stop("Misspecified nterm. Must be larger than 0") .Fortran("set_nterm",m=as.integer(nterm), PACKAGE = "acepack") } invisible(NULL) }acepack/R/ace.R0000644000176200001440000002777114753173363012747 0ustar liggesusers ############################################################################# # # This file is part of acepack. # # Copyright 1985,2007 Jerome H. Friedman # Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center # # Permission to use, copy, modify, distribute, and sell this software and # its documentation for any purpose is hereby granted without fee, # provided that the above copyright notice appear in all copies and that # both that copyright notice and this permission notice appear in # supporting documentation. No representations are made about the # suitability of this software for any purpose. It is provided "as is" # without express or implied warranty. ############################################################################### #' @name ace #' @title Alternating Conditional Expectations #' #' @param x matrix; A matrix containing the independent variables. #' @param y numeric; A vector containing the response variable. #' @param wt numeric; An optional vector of weights. #' @param cat integer; An optional integer vector specifying which variables #' assume categorical values. Positive values in \code{cat} refer to columns #' of the \code{x} matrix and zero to the response variable. Variables must #' be numeric, so a character variable should first be transformed with #' as.numeric() and then specified as categorical. #' @param mon integer; An optional integer vector specifying which variables are #' to be transformed by monotone transformations. Positive values #' in \code{mon} refer to columns of the \code{x} matrix and zero to the #' response variable. #' @param lin integer; An optional integer vector specifying which variables are #' to be transformed by linear transformations. Positive values in \code{lin} #' refer to columns of the \code{x} matrix and zero to the response variable. #' @param circ integer; An integer vector specifying which variables assume #' circular (periodic) values. Positive values in \code{circ} refer to #' columns of the \code{x} matrix and zero to the response variable. #' @param delrsq numeric(1); termination threshold. Iteration stops when #' R-squared changes by less than \code{delrsq} in 3 consecutive iterations #' (default 0.01). #' @param control named list; control parameters to set. Documented at #' \code{\link{set_control}}. #' @param on.error function; call back for when ierr is not equal to zero. Defaults to warning. #' @param formula formula; an object of class "\code{\link{formula}}": a #' symbolic description of the model to be smoothed. #' @param data an optional data frame, list or environment (or object coercible #' by \code{\link{as.data.frame}} to a data frame) containing the variables in #' the model. If not found in data, the variables are taken from #' \code{environment(formula)}, typically the environment from which #' \code{ace} is called. #' @param subset an optional vector specifying a subset of observations to be #' used in the fitting process. Only used when a \code{formula} #' is specified. #' @param na.action a function which indicates what should happen when the data #' contain NAs. The default is set by the \code{na.action} setting of #' \code{\link{options}}, and is \code{\link{na.fail}} if that is unset. #' The ‘factory-fresh’ default is \code{\link{na.omit}}. Another possible #' value is NULL, no action. Value \code{\link{na.exclude}} can be useful. #' @param ... additional arguments which go ignored for ace call. Included for S3 dispatch #' consistency. They are utilized when using print as they get passed to cat. #' Also when plotting an ace object they are passed to plot. #' @param digits rounding digits for summary/print #' @param object an S3 ace object #' @param which when plotting an ace object which plots to produce. #' @param caption a list of captions for a plot. #' @param xlab the x-axis label when plotting. #' @param ylab the y-axis label when plotting. #' @param ask when plotting should the terminal be asked for input between plots. #' @return #' A structure with the following components: #' \item{x}{the input x matrix.} #' \item{y}{the input y vector.} #' \item{tx}{the transformed x values.} #' \item{ty}{the transformed y values.} #' \item{rsq}{the multiple R-squared value for the transformed values.} #' \item{l}{the codes for cat, mon, ...} #' #' @description #' Uses the alternating conditional expectations algorithm to find the #' transformations of y and x that maximize the proportion of variation #' in y explained by x. When x is a matrix, it is transformed so that #' its columns are equally weighted when predicting y. #' #' @references #' Breiman and Friedman, Journal of the American Statistical #' Association (September, 1985). #' #' The R code is adapted from S code for avas() by Tibshirani, in the #' Statlib S archive; the FORTRAN is a double-precision version of #' FORTRAN code by Friedman and Spector in the Statlib general archive. #' #' @examples #' #' TWOPI <- 8*atan(1) #' x <- runif(200,0,TWOPI) #' y <- exp(sin(x)+rnorm(200)/2) #' a <- ace(x,y) #' par(mfrow=c(3,1)) #' plot(a$y,a$ty) # view the response transformation #' plot(a$x,a$tx) # view the carrier transformation #' plot(a$tx,a$ty) # examine the linearity of the fitted model #' #' # example when x is a matrix #' X1 <- 1:10 #' X2 <- X1^2 #' X <- cbind(X1,X2) #' Y <- 3*X1+X2 #' a1 <- ace(X,Y) #' par(mfrow=c(1,1)) #' plot(rowSums(a1$tx),a1$y) #' (lm(a1$y ~ a1$tx)) # shows that the colums of X are equally weighted #' #' # From D. Wang and M. Murphy (2005), Identifying nonlinear relationships #' # regression using the ACE algorithm. Journal of Applied Statistics, #' # 32, 243-258. #' X1 <- runif(100)*2-1 #' X2 <- runif(100)*2-1 #' X3 <- runif(100)*2-1 #' X4 <- runif(100)*2-1 #' #' # Original equation of Y: #' Y <- log(4 + sin(3*X1) + abs(X2) + X3^2 + X4 + .1*rnorm(100)) #' #' # Transformed version so that Y, after transformation, is a #' # linear function of transforms of the X variables: #' # exp(Y) = 4 + sin(3*X1) + abs(X2) + X3^2 + X4 #' #' a1 <- ace(cbind(X1,X2,X3,X4),Y) #' #' # For each variable, show its transform as a function of #' # the original variable and the of the transform that created it, #' # showing that the transform is recovered. #' par(mfrow=c(2,1)) #' #' plot(X1,a1$tx[,1]) #' plot(sin(3*X1),a1$tx[,1]) #' #' plot(X2,a1$tx[,2]) #' plot(abs(X2),a1$tx[,2]) #' #' plot(X3,a1$tx[,3]) #' plot(X3^2,a1$tx[,3]) #' #' plot(X4,a1$tx[,4]) #' plot(X4,a1$tx[,4]) #' #' plot(Y,a1$ty) #' plot(exp(Y),a1$ty) #' #' @rdname ace #' @export #' @useDynLib acepack, .registration=TRUE #' ace <- function(...) UseMethod("ace") # Internal function to handle error ace_error <- function(ierr, FUN) { if(!inherits(FUN, 'function')) return(NULL) if(ierr==1 || ierr==2) FUN("Weights must be greater than zero or Y has no variance.") if(ierr==3 || ierr==4 || ierr==5 || ierr==6) FUN("Internal error. Variable category misspecified or no variance in a dimension.") if(ierr != 0) FUN(paste("Internal error. Unknown ierr", ierr, "returned.")) } #' @rdname ace #' @export ace.default <- function( x, y, wt = NULL, cat = NULL, mon = NULL, lin = NULL, circ = NULL, delrsq = 0.01, control = NULL, on.error = warning, ...) { if(!is.null(control)) do.call(set_control, control) x <- as.matrix(x) if(is.null(wt)) wt <- rep(1, nrow(x)) if (delrsq <= 0) stop("delrsq must be positive") iy <- ncol(x) + 1 l <- matrix(1, ncol = iy) if (!is.null(circ)) { for (i in 1:length(circ)) { if (circ[i] < 0 || circ[i] > ncol(x)) stop("bad circ= specification") nncol <- if (circ[i] == 0) iy else circ[i] if (l[nncol] != 2 & l[nncol] != 1) stop("conflicting transformation specifications") l[nncol] <- 2 } } if (length(mon) > 0) { for (i in 1:length(mon)) { if (mon[i] < 0 || mon[i] > ncol(x)) stop("bad mon= specification") nncol <- if (mon[i] == 0) iy else mon[i] if (l[nncol] != 3 && l[nncol] != 1) stop("conflicting transformation specifications") l[nncol] <- 3 } } if (length(lin)>0) { for (i in 1:length(lin)) { if (lin[i] < 0 || lin[i] > ncol(x)) stop("bad lin= specification") nncol <- if (lin[i] == 0) iy else lin[i] if (l[nncol] != 4 && l[nncol] != 1) stop("conflicting transformation specifications") l[nncol] <- 4 } } if (length(cat)) { for (i in 1:length(cat)) { if (cat[i] < 0 || cat[i] > ncol(x)) stop("bad cat= specification") nncol <- if (cat[i] == 0) iy else cat[i] if (l[nncol] != 5 && l[nncol] != 1) stop("conflicting transformation specifications") l[nncol] <- 5 } } tx <- x ty <- y m <- matrix(0, nrow = nrow(x), ncol = iy) z <- matrix(0, nrow = nrow(x), ncol = 12) ns <- 1 mode(x) <- "double" mode(y) <- "double" mode(tx) <- "double" mode(ty) <- "double" mode(wt) <- "double" mode(delrsq) <- "double" mode(z) <- "double" results <- structure( .Fortran("mace", p = as.integer(ncol(x)), n = as.integer(nrow(x)), x = t(x), y = y, w = as.double(wt), l = as.integer(l), delrsq = delrsq, ns = as.integer(ns), tx = tx, ty = ty, rsq = double(1), ierr = integer(1), m = as.integer(m), z = z, PACKAGE = "acepack"), class=c("ace","list")) if(results$ierr != 0) ace_error(results$ierr, on.error) # Find original R^2 results$orig_rsq <- summary(lm(results$y ~ t(results$x)))$r.squared results } #' @rdname ace #' @importFrom stats model.frame #' @export ace.formula <- function( formula, data = NULL, subset = NULL, na.action = getOption('na.action'), ...) { # Copied from lm() mf <- match.call(expand.dots = FALSE) m <- match(c("formula", "data", "subset", "na.action"), names(mf), 0L) mf <- mf[c(1L, m)] mf$drop.unused.levels <- TRUE mf[[1L]] <- quote(stats::model.frame) mf <- eval(mf, parent.frame()) ace(mf[,2:ncol(mf)],mf[,1],...) } #' @rdname ace #' @export summary.ace <- function(object, ...) { object$print_summary <- TRUE object } #' @rdname ace #' @importFrom stats lm #' @export print.ace <- function(x, ..., digits=4) { x$rsq <- round(x$rsq, digits) x$orig_rsq <- round(x$orig_rsq, digits) cat('\nAlternating Conditional Expections\n\n', ...) cat('p =', x$p, ', N =', x$n, '\n\n', ...) cat('Raw Multiple R-squared:', x$orig_rsq, '\n', ...) cat('Transformed Multiple R-squared:', x$rsq, '\n', ...) cat('\n', ...) if(!is.null(x$print_summary) && x$print_summary) { cat('Original Y\n', ...) print(summary(x$y)) cat('\nTransformed Y\n', ...) print(summary(x$ty)) cat('\nOriginal X\n', ...) print(summary(t(x$x))) cat('\nTransformed X\n', ...) print(summary(x$tx)) } } #' @rdname ace #' @importFrom graphics par #' @importFrom grDevices as.graphicsAnnot #' @importFrom grDevices dev.flush #' @importFrom grDevices dev.hold #' @importFrom grDevices dev.interactive #' @importFrom grDevices devAskNewPage #' @export plot.ace <- function( x, ..., which=1:(x$p+1), caption=c(list("Response Y ACE Transformation"), as.list(paste("Carrier", rownames(x$x), "ACE Transformation"))), xlab = "Original", ylab = "Transformed", ask = prod(par("mfcol")) < length(which) && dev.interactive() ) { show <- rep(FALSE, x$p+1) show[which] <- TRUE getCaption <- function(k) # allow caption = "" , plotmath etc if(length(caption) < k) NA_character_ else as.graphicsAnnot(caption[[k]]) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } if(show[1L]) { dev.hold() plot(x$y, x$ty, main=getCaption(1), xlab=xlab, ylab=ylab, ...) dev.flush() } for(i in 1L:(x$p)) if(show[i+1]) { dev.hold() plot(x$x[i,], x$tx[,i], main=getCaption(i+1), xlab=xlab, ylab=ylab, ...) dev.flush() } } acepack/R/avas.R0000644000176200001440000002672714753164167013153 0ustar liggesusers ############################################################################# # # This file is part of acepack. # # Copyright 1985,2007 Jerome H. Friedman # Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center # # Permission to use, copy, modify, distribute, and sell this software and # its documentation for any purpose is hereby granted without fee, # provided that the above copyright notice appear in all copies and that # both that copyright notice and this permission notice appear in # supporting documentation. No representations are made about the # suitability of this software for any purpose. It is provided "as is" # without express or implied warranty. ############################################################################### #' @name avas #' @title Additivity and variance stabilization for regression #' @description Estimate transformations of \code{x} and \code{y} such that #' the regression of \code{y} on \code{x} is approximately linear with #' constant variance #' @param x matrix containing the independent variables. #' @param y a vector containing the response variable. #' @param wt an optional vector of weights. #' @param cat an optional integer vector specifying which variables #' assume categorical values. Positive values in \code{cat} refer #' to columns of the \code{x} matrix and zero to the response #' variable. Variables must be numeric, so a character variable #' should first be transformed with as.numeric() and then specified # ' as categorical. #' @param mon an optional integer vector specifying which variables are #' to be transformed by monotone transformations. Positive values #' in \code{mon} refer to columns of the \code{x} matrix and zero #' to the response variable. #' @param lin an optional integer vector specifying which variables are #' to be transformed by linear transformations. Positive values in #' \code{lin} refer to columns of the \code{x} matrix and zero to #' the response variable. #' @param circ an integer vector specifying which variables assume #' circular (periodic) values. Positive values in \code{circ} #' refer to columns of the \code{x} matrix and zero to the response #' variable. #' @param delrsq numeric(1); Termination threshold for iteration. Stops when #' R-squared changes by less than \code{delrsq} in 3 consecutive iterations #' (default 0.01). #' @param yspan yspan Optional window size parameter for smoothing the #' variance. Range is \eqn{[0,1]}. Default is 0 (cross validated #' choice). .5 is a reasonable alternative to try. #' @param control named list; control parameters to set. Documented at #' \code{\link{set_control}}. #' @param formula formula; an object of class "\code{\link{formula}}": a #' symbolic description of the model to be smoothed. #' @param data an optional data frame, list or environment (or object coercible #' by \code{\link{as.data.frame}} to a data frame) containing the variables in #' the model. If not found in data, the variables are taken from #' \code{environment(formula)}, typically the environment from which #' \code{ace} is called. #' @param subset an optional vector specifying a subset of observations to be #' used in the fitting process. Only used when a \code{formula} #' is specified. #' @param na.action a function which indicates what should happen when the data #' contain NAs. The default is set by the \code{na.action} setting of #' \code{\link{options}}, and is \code{\link{na.fail}} if that is unset. #' The ‘factory-fresh’ default is \code{\link{na.omit}}. Another possible #' value is NULL, no action. Value \code{\link{na.exclude}} can be useful. #' @param ... additional arguments which go ignored for avas call. Included for S3 dispatch #' consistency. They are utilized when using print as they get passed to cat. #' Also when plotting an ace object they are passed to plot. #' @param digits rounding digits for summary/print #' @param object an S3 ace object #' @param which when plotting an ace object which plots to produce. #' @param caption a list of captions for a plot. #' @param xlab the x-axis label when plotting. #' @param ylab the y-axis label when plotting. #' @param ask when plotting should the terminal be asked for input between plots. #' @return #' A structure with the following components: #' \item{x}{the input x matrix.} #' \item{y}{the input y vector.} #' \item{tx}{the transformed x values.} #' \item{ty}{the transformed y values.} #' \item{rsq}{the multiple R-squared value for the transformed values.} #' \item{l}{the codes for cat, mon, ...} #' \item{m}{not used in this version of avas} #' \item{yspan}{span used for smoothing the variance} #' \item{iters}{iteration number and rsq for that iteration} #' \item{niters}{number of iterations used} #' #' @references #' Rob Tibshirani (1987), #' ``Estimating optimal transformations for regression''. #' \emph{Journal of the American Statistical Association} \bold{83}, #' 394ff. #' @examples #' #' TWOPI <- 8*atan(1) #' x <- runif(200,0,TWOPI) #' y <- exp(sin(x)+rnorm(200)/2) #' a <- avas(x,y) #' plot(a) # View response and carrier transformations #' plot(a$tx,a$ty) # examine the linearity of the fitted model #' #' # From D. Wang and M. Murphy (2005), Identifying nonlinear relationships #' # regression using the ACE algorithm. Journal of Applied Statistics, #' # 32, 243-258, adapted for avas. #' X1 <- runif(100)*2-1 #' X2 <- runif(100)*2-1 #' X3 <- runif(100)*2-1 #' X4 <- runif(100)*2-1 #' #' # Original equation of Y: #' Y <- log(4 + sin(3*X1) + abs(X2) + X3^2 + X4 + .1*rnorm(100)) #' #' # Transformed version so that Y, after transformation, is a #' # linear function of transforms of the X variables: #' # exp(Y) = 4 + sin(3*X1) + abs(X2) + X3^2 + X4 #' #' a1 <- avas(cbind(X1,X2,X3,X4),Y) #' #' par(mfrow=c(2,1)) #' #' # For each variable, show its transform as a function of #' # the original variable and the of the transform that created it, #' # showing that the transform is recovered. #' plot(X1,a1$tx[,1]) #' plot(sin(3*X1),a1$tx[,1]) #' #' plot(X2,a1$tx[,2]) #' plot(abs(X2),a1$tx[,2]) #' #' plot(X3,a1$tx[,3]) #' plot(X3^2,a1$tx[,3]) #' #' plot(X4,a1$tx[,4]) #' plot(X4,a1$tx[,4]) #' #' plot(Y,a1$ty) #' plot(exp(Y),a1$ty) #' #' @export #' @rdname avas avas <- function(...) UseMethod("avas") #' @rdname avas #' @export avas.default <- function( x, y, wt = NULL, cat = NULL, mon = NULL, lin = NULL, circ = NULL, delrsq = 0.01, yspan = 0, control = NULL, ...) { if(!is.null(control)) do.call(set_control, control) if (delrsq <= 0) stop("delrsq must be positive") x <- as.matrix(x) if(is.null(wt)) wt <- rep(1, nrow(x)) iy <- ncol(x) + 1 l <- matrix(1, ncol = iy) if(length(circ) > 0) { for (i in 1:length(circ)) { if (circ[i] < 0 || circ[i] > ncol(x)) stop("bad circ= specification") nncol <- if (circ[i] == 0) iy else circ[i] if (l[nncol] != 2 & l[nncol] != 1) stop("conflicting transformation specifications") l[nncol] <- 2 } } if (length(mon)>0) { for (i in 1:length(mon)) { if (mon[i] < 0 || mon[i] > ncol(x)) stop("bad mon= specification") nncol <- if (mon[i] == 0) iy else mon[i] if (l[nncol] != 3 && l[nncol] != 1) stop("conflicting transformation specifications") l[nncol] <- 3 } } if (length(lin)>0) { for (i in 1:length(lin)) { if (lin[i] < 0 || lin[i] > ncol(x)) stop("bad lin= specification") nncol <- if (lin[i] == 0) iy else lin[i] if (l[nncol] != 4 && l[nncol] != 1) stop("conflicting transformation specifications") l[nncol] <- 4 } } if (length(cat)) { for (i in 1:length(cat)) { if (cat[i] < 0 || cat[i] > ncol(x)) stop("bad cat= specification") nncol <- if (cat[i] == 0) iy else cat[i] if (l[nncol] != 5 && l[nncol] != 1) stop("conflicting transformation specifications") l[nncol] <- 5 } } tx <- x ty <- y m <- matrix(0, nrow = nrow(x), ncol = ncol(x) + 2) z <- matrix(0, nrow = nrow(x), ncol = 17) iters <- matrix(0, nrow = 100, ncol = 2) mode(x) <- "double" mode(y) <- "double" mode(tx) <- "double" mode(ty) <- "double" mode(wt) <- "double" mode(m) <- "integer" mode(l) <- "integer" mode(delrsq) <- "double" mode(z) <- "double" mode(yspan) <- "double" mode(iters) <- "double" junk <- .Fortran("favas", as.integer(ncol(x)), as.integer(nrow(x)), x, y, wt, l, delrsq, tx = tx, ty = ty, rsq = double(1), ierr = integer(1), m, z, yspan = yspan, niter = integer(1), iters = iters, PACKAGE = "acepack") junk$iters <- junk$iters[1:junk$niter, ] results <- structure( list(x = t(x), y = y, tx = junk$tx, ty = junk$ty, rsq = junk$rsq, l=l, m, yspan = junk$yspan, iters = junk$iters, niters = junk$niter, p=ncol(x)), class=c("avas", "list") ) # Find original R^2 results$orig_rsq <- summary(lm(results$y ~ t(results$x)))$r.squared results } #' @rdname avas #' @importFrom stats model.frame #' @export avas.formula <- function( formula, data = NULL, subset = NULL, na.action = getOption('na.action'), ...) { # Copied from lm() mf <- match.call(expand.dots = FALSE) m <- match(c("formula", "data", "subset", "na.action"), names(mf), 0L) mf <- mf[c(1L, m)] mf$drop.unused.levels <- TRUE mf[[1L]] <- quote(stats::model.frame) mf <- eval(mf, parent.frame()) avas(mf[,2:ncol(mf)],mf[,1],...) } #' @rdname avas #' @export summary.avas <- function(object, ...) { object$print_summary <- TRUE object } #' @rdname avas #' @importFrom stats lm #' @export print.avas <- function(x, ..., digits=4) { # Find original R^2 x$orig_rsq <- round(x$orig_rsq, digits) x$rsq <- round(x$rsq, digits) cat('\nAdditivity and Variance Stabilization\n\n', ...) cat('p =', x$p, ', N =', ncol(x$x), '\n\n', ...) cat('Raw Multiple R-squared:', x$orig_rsq, '\n', ...) cat('Transformed Multiple R-squared:', x$rsq, '\n', ...) cat('\n', ...) if(!is.null(x$print_summary) && x$print_summary) { cat('Original Y\n', ...) print(summary(x$y)) cat('\nTransformed Y\n', ...) print(summary(x$ty)) cat('\nOriginal X\n', ...) print(summary(t(x$x))) cat('\nTransformed X\n', ...) print(summary(x$tx)) } } #' @rdname avas #' @importFrom graphics par #' @importFrom grDevices as.graphicsAnnot #' @importFrom grDevices dev.flush #' @importFrom grDevices dev.hold #' @importFrom grDevices dev.interactive #' @importFrom grDevices devAskNewPage #' @export plot.avas <- function( x, ..., which=1:(x$p+1), caption=c(list("Response Y AVAS Transformation"), as.list(paste("Carrier", rownames(x$x), "AVAS Transformation"))), xlab = "Original", ylab = "Transformed", ask = prod(par("mfcol")) < length(which) && dev.interactive() ) { show <- rep(FALSE, x$p+1) show[which] <- TRUE getCaption <- function(k) # allow caption = "" , plotmath etc if(length(caption) < k) NA_character_ else as.graphicsAnnot(caption[[k]]) if (ask) { oask <- devAskNewPage(TRUE) on.exit(devAskNewPage(oask)) } if(show[1L]) { dev.hold() plot(x$y, x$ty, main=getCaption(1), xlab=xlab, ylab=ylab, ...) dev.flush() } for(i in 1L:(x$p)) if(show[i+1]) { dev.hold() plot(x$x[i,], x$tx[,i], main=getCaption(i+1), xlab=xlab, ylab=ylab, ...) dev.flush() } } acepack/LICENSE.note0000644000176200001440000001304714753135631013627 0ustar liggesusersFor the AVAS license, see README.avas. The following, concerning ACE, written by Tom "spot" Callaway, is from the Fedora R-acepack RPM. ######################## The copyright on the ace implementation was clear, but its licensing terms were not. I was able to clarify the terms with the copyright holder: Copyright 2007 Jerome H. Friedman Permission to use, copy, modify, distribute, and sell this software and its documentation for any purpose is hereby granted without fee, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation. No representations are made about the suitability of this software for any purpose. It is provided "as is" without express or implied warranty. ========================================================================= To remove any hint of impropriety, here are copies of my email communications with the copyright holder. From: "Jerome H. Friedman" To: "Tom \"spot\" Callaway" Subject: Re: license for ace() Date: Wed, 31 Oct 2007 11:05:10 -0800 Tom, >> > We would like to include it in Fedora, but we need to know the >> > licensing >> > terms for that code. >> >> Sorry for my ignorance, but what is Fedora? > > Fedora is a very popular distribution of Linux. Our previous name was > "Red Hat Linux". Right. I should have remembered that. You hereby have my permission to distribute my ACE code in Fedora. Cheers, Jerry. From tcallawa@redhat.com Wed Oct 31 15:10:12 2007 Subject: Re: license for ace() From: "Tom \"spot\" Callaway" To: "Jerome H. Friedman" Date: Wed, 31 Oct 2007 15:10:12 -0400 On Wed, 2007-10-31 at 11:05 -0800, Jerome H. Friedman wrote: > Tom, > > >> > We would like to include it in Fedora, but we need to know the > >> > licensing > >> > terms for that code. > >> > >> Sorry for my ignorance, but what is Fedora? > > > > Fedora is a very popular distribution of Linux. Our previous name was > > "Red Hat Linux". > > Right. I should have remembered that. > > You hereby have my permission to distribute my ACE code in Fedora. Great! Now, I just need to know under what licensing terms we can distribute it under. :) Here are several common licenses: MIT ==== Copyright 19XX John Doe Permission to use, copy, modify, distribute, and sell this software and its documentation for any purpose is hereby granted without fee, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation. No representations are made about the suitability of this software for any purpose. It is provided "as is" without express or implied warranty. BSD ==== Copyright (c) , All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. GPLv2 ====== http://www.gnu.org/licenses/old-licenses/gpl-2.0.html If none of those licenses seems correct to you, let me know, and I will show you some others. Thanks, ~Tom From: "Jerome H. Friedman" To: "Tom \"spot\" Callaway" Subject: Re: license for ace() Date: Wed, 31 Oct 2007 11:43:34 -0800 Tom, > MIT > ==== > Copyright 19XX John Doe > > Permission to use, copy, modify, distribute, and sell this software and > its documentation for any purpose is hereby granted without fee, > provided that the above copyright notice appear in all copies and that > both that copyright notice and this permission notice appear in > supporting documentation. No representations are made about the > suitability of this software for any purpose. It is provided "as is" > without express or implied warranty. I think this is good enough. Jerry. ############# Am 07.02.2025 um 00:04 schrieb Garbett, Shawn P: > Bernhard, > > Please review the following and see if it's acceptable for you. > > https://github.com/vubiostat/acepack/commit/c8b9da412838cfa573a6033778339039ca3c8d17 > yes > One note is that the acepack is MIT license and your code was GPL-2. To publish under MIT I will need your acknowledgement that this is okay to continue. Yes, we accept the MIT license. acepack/src/0000755000176200001440000000000014753230000012422 5ustar liggesusersacepack/src/model.f900000644000176200001440000000525414744022052014056 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ ! Computes response predictive function f for the model yhat = f(t), ! where ! p ! f(t) = e(y : t), t = sum tx ( x ) ! i=1 ! using the x transformations tx constructed by subroutine ace. ! if y is a categorical variable (classification) then ! -1 ! f(t) = ty (t). ! input: ! ! p,n,y,w,l : same input as for subroutine ace. ! tx,ty,m,z : output from subroutine ace. ! ! output: ! ! f(n),t(n) : input for subroutine acemod. ! ! note: this subroutine must be called before subroutine acemod. ! SUBROUTINE model(p, n, y, w, l, tx, ty, f, t, m, z) USE acedata IMPLICIT NONE ! Input/Output arguments INTEGER, INTENT(IN) :: p, n INTEGER, INTENT(INOUT) :: l(1), m(n, 1) DOUBLE PRECISION, INTENT(IN) :: y(n), w(n), tx(n, p), ty(n) DOUBLE PRECISION, INTENT(OUT) :: f(n), t(n), z(n, 12) ! Local variables INTEGER :: j, k, j1, j2, pp1 pp1 = p + 1 IF (ABS(l(pp1)) == 5) THEN t(:) = ty(:) m(:, pp1) = reshape([(j, j=1,n)], shape=[n]) ! 1:n ELSE DO j = 1, n t(j) = sum(tx(j, :)) m(j, pp1) = j END DO END IF CALL sort(t, m(:, pp1), 1, n) ! Loop for populating z DO j = 1, n k = m(j, pp1) z(j, 2) = w(k) IF (y(k) >= big) CYCLE ! Skip updating z(j, 1) z(j, 1) = y(k) END DO j1=j j2=j1 DO WHILE (y(m(j1,pp1)) >= big) j1 = j1 - 1 IF (j1 < 1) EXIT END DO DO WHILE (y(m(j2,pp1)) >= big) j2 = j2 + 1 IF (j2 > n) EXIT END DO IF (j1 < 1) THEN k=j2 ELSE IF (j2 > n) THEN k=j1 ELSE IF (t(j)-t(j1).ge.t(j2)-t(j)) THEN k=j2 ELSE k=j1 END IF z(j, 1) = y(m(k, pp1)) t(j) = t(k) ! Smoothness check IF (ABS(l(pp1)) == 5) THEN f(:) = z(:, 1) ELSE CALL smothr(1, n, t, z, z(:, 2), f, z(:, 6)) END IF RETURN END SUBROUTINE model acepack/src/ctsub.f900000644000176200001440000000257414744022052014100 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ SUBROUTINE ctsub(n,u,v,y,ty) IMPLICIT NONE INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(IN) :: u(n), v(n), y(n) DOUBLE PRECISION, INTENT(OUT) :: ty(n) INTEGER :: i,j DO i=1,n IF (y(i) <= u(1)) THEN ty(i)=(y(i)-u(1))*v(1) ELSE ty(i)=0.0 DO j=1,n IF (y(i) <= u(j)) EXIT IF (j > 1) ty(i)=ty(i)+(u(j)-u(j-1))*(v(j)+v(j-1))/2 END DO IF (y(i) <= u(n)) THEN ty(i)=ty(i)+.5*(y(i)-u(j-1))*(2*v(j-1)+(y(i)-u(j-1))*(v(j)-v(j-1))/(u(j)-u(j-1))) ELSE ty(i)=ty(i)+(y(i)-u(n))*v(n) END IF END IF END DO END SUBROUTINE ctsubacepack/src/acemod.f900000644000176200001440000000654114744022052014206 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ ! 2025-01-02 Shawn Garbett ChatGPT assisted refactor ! ! computes response y estimates from the model ! ! yhat = f ( t( v ) ) ! ! using the x transformations tx constructed by subroutine ace and ! the predictor function (f,t) constructed by subroutine model. ! ! input: ! ! v(p) : vector of predictor values. ! p,n,x,l : same input as for subroutine ace. ! tx,m : output from subroutine ace. ! f,t : output from subroutine model. ! ! output: ! ! yhat : estimated response value for v. ! ! note: this subroutine must not be called before subroutine model. ! SUBROUTINE acemod(v, p, n, x, l, tx, f, t, m, yhat) USE acedata IMPLICIT NONE INTEGER, INTENT(IN) :: p, n DOUBLE PRECISION, INTENT(IN) :: v(p) DOUBLE PRECISION, INTENT(IN) :: x(p, n) INTEGER, INTENT(IN) :: l(1) DOUBLE PRECISION, INTENT(IN) :: tx(n, p), f(n), t(n) INTEGER, INTENT(IN) :: m(n, 1) DOUBLE PRECISION, INTENT(OUT) :: yhat INTEGER :: low, high, place INTEGER :: i, jh, jl DOUBLE PRECISION :: th, vi, xt th = 0.0 DO i=1,p IF (l(i) == 0) EXIT vi=v(i) IF (vi >= big) THEN IF (x(i,m(n,i)) >= big) th=th+tx(m(n,i),i) CYCLE END IF IF (vi <= x(i, m(1,i))) THEN place=1 th=th+tx(m(place,i),i) CYCLE END IF IF (vi >= x(i, m(n,i))) THEN place=n th=th+tx(m(place,i),i) CYCLE END IF low=0 high=n+1 DO WHILE (low+1 < high) place=(low+high)/2 xt=x(i,m(place,i)) IF (vi == xt) THEN th=th+tx(m(place,i),i) CYCLE END IF IF (vi < xt) THEN high = place ELSE low = place END IF END DO IF (iabs(l(i)) == 5) CYCLE jl=m(low,i) jh=m(high,i) IF (x(i,jh) >= big) THEN th=th+tx(jl,i) ELSE th=th+tx(jl,i)+(tx(jh,i)-tx(jl,i))*(vi-x(i,jl))/(x(i,jh)-x(i,jl)) END IF END DO IF (th > t(1)) THEN yhat = f(1) RETURN ELSEIF (th < t(n)) THEN yhat = f(n) RETURN ELSE low = 0 high = n + 1 DO WHILE (low + 1 < high) place = (low + high) / 2 xt = t(place) IF (th == xt) THEN yhat = f(place) RETURN ELSEIF (th >= xt) THEN low = place ELSE high = place END IF END DO IF (IABS(l(p + 1)) /= 5) THEN yhat = f(low) + (f(high) - f(low)) * (th - t(low)) / (t(high) - t(low)) ELSE IF (th - t(low) > t(high) - th) THEN yhat = f(high) ELSE yhat = f(low) END IF END IF END IF END SUBROUTINE acemod acepack/src/supsmu.f900000644000176200001440000000634014745712674014330 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1984,1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ ! Inputs: ! n : number of observations (x,y - pairs). ! x(n) : ordered abscissa values. ! y(n) : corresponding ordinate (response) values. ! w(n) : weight for each (x,y) observation. ! iper : periodic variable flag. ! iper=1 => x is ordered interval variable. ! iper=2 => x is a periodic variable with values ! in the range (0.0,1.0) and period 1.0. ! Outputs: ! smo(n) : smoothed ordinate (response) values. ! scratch: ! scratch(n,7) : internal working storage. ! ! See acedata for global control parameters SUBROUTINE supsmu (n,x,y,w,iper,smo,scratch) USE acedata IMPLICIT NONE INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(IN) :: x(n), y(n), w(n) INTEGER, INTENT(IN) :: iper DOUBLE PRECISION, INTENT(OUT) :: smo(n), scratch(n,7) INTEGER :: i, j, jper DOUBLE PRECISION :: h(1), sw, sy, a, scale, vsmlsq, resmin, f IF (x(n) <= x(1)) THEN sy = sum(w(:)*y(:)) sw = sum(w(:)) a=sy/sw smo(:) = a RETURN END IF i=n/4 j=3*i scale=x(j)-x(i) DO WHILE (scale <= 0.0) IF (j < n) j=j+1 IF (i > 1) i=i-1 scale=x(j)-x(i) END DO vsmlsq=(eps*scale)**2 jper=iper IF (iper==2 .and. (x(1) < 0.0 .or. x(n) > 1.0)) jper=1 IF (jper < 1 .or. jper > 2) jper=1 IF (span > 0.0) THEN CALL smooth (n,x,y,w,span,jper,vsmlsq,smo,scratch(1,1)) RETURN END IF DO i=1,3 CALL smooth (n,x,y,w,spans(i),jper,vsmlsq,scratch(1,2*i-1),scratch(1,7)) CALL smooth (n,x,scratch(1,7),w,spans(2),-jper,vsmlsq,scratch(1,2*i),h) END DO DO j=1,n resmin=big DO i=1,3 IF (scratch(j, 2*i) < resmin) THEN resmin=scratch(j,2*i) scratch(j,7)=spans(i) END IF END DO IF (alpha > 0.0 .and. alpha <= 10.0 .and. resmin < scratch(j,6)) THEN scratch(j,7) = scratch(j,7) + & (spans(3)-scratch(j,7))*max(sml,resmin/scratch(j,6))**(10.0-alpha) END IF END DO CALL smooth (n,x,scratch(1,7),w,spans(2),-jper,vsmlsq,scratch(1,2),h) DO j=1,n IF (scratch(j,2) <= spans(1)) scratch(j,2)=spans(1) IF (scratch(j,2) >= spans(3)) scratch(j,2)=spans(3) f=scratch(j,2)-spans(2) IF (f >= 0.0) THEN f=f/(spans(3)-spans(2)) scratch(j,4)=(1.0-f)*scratch(j,3)+f*scratch(j,5) ELSE f=-f/(spans(2)-spans(1)) scratch(j,4)=(1.0-f)*scratch(j,3)+f*scratch(j,1) END IF END DO CALL smooth (n,x,scratch(1,4),w,spans(1),-jper,vsmlsq,smo,h) END SUBROUTINE supsmu acepack/src/acedata.f900000644000176200001440000001143614744022052014337 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ ! ! 2025-01-02 Shawn Garbett ! ChatGPT assisted refactor. Changed to a module. Elminated implicits. ! ! There are SET_* routines for each parameter available. ! These parameters are used in the smoothing routines of ACE and AVAS. ACE and ! AVAS both have their own smoothing implementations. ! ! maxit : integer(1); ACE and AVAS; Maximum number of iterations. Default is 20. ! ! nterm : integer(1); ACE and AVAS; Number of consecutive iterations for which ! rsq must change less than delcor for convergence. Default is 3. ! ! span : double(1); ACE and AVAS; Span to use in smoothing represents the ! fraction of observations in smoothing window. Automatic span selection ! is performed if set to 0.0. Default is 0.0 (automatic). ! ! For small samples (n < 40) or if there are substantial serial ! correlations between obserations close in x - value, then ! a prespecified fixed span smoother (span > 0) should be ! used. Reasonable span values are 0.3 to 0.5. ! ! spans : double(3); AVAS span values for the three running linear smoothers. ! * spans(1) : tweeter span. Default is 0.05. ! * spans(2) : midrange span. Default is 0.2. ! * spans(3) : woofer span. Default is 0.5. ! Warning: These span values should be changed only with great care. ! ! alpha : double(1); AVAS; Controls high frequency (small span) penality ! used with automatic span selection (base tone control). An ! alpha < 0.0 or alpha > 10.0 results in no effect. Default is 5.0. ! ! big : double(1); ACE and AVAS; a large representable floating point number. ! Default is 1.0e30. ! ! sml : double(1); AVAS; A small number. Should be set so that (sml)**(10.0) ! does not cause floating point underflow Default is 1e-30. ! ! eps : double(1); AVAS; Used to numerically stabilize slope calculations ! for running linear fits. ! ! References ! ! J Friedman, W Stuetzle. Smoothing of Scatterplots. Stanford Project Orion. ! July 1982 ! ! J Friedman. A Variable Span Smoother. LCS Technical Report No. 5. SLAC ! PUB-3477. November 1984 MODULE acedata IMPLICIT NONE DOUBLE PRECISION :: alpha = 5.0 DOUBLE PRECISION :: big = 1.0e30 DOUBLE PRECISION :: span = 0.0 DOUBLE PRECISION :: sml = 1.0e-30 DOUBLE PRECISION :: eps = 1e-3 DOUBLE PRECISION :: spans(3) = (/0.05, 0.2, 0.5/) INTEGER :: maxit = 20 INTEGER :: nterm = 3 PUBLIC :: set_alpha PUBLIC :: set_big PUBLIC :: set_span PUBLIC :: set_sml PUBLIC :: set_eps PUBLIC :: set_spans CONTAINS SUBROUTINE set_alpha(a) BIND(C, name="set_alpha_") USE, INTRINSIC :: iso_c_binding IMPLICIT NONE REAL(c_double), INTENT(IN) :: a alpha = a END SUBROUTINE set_alpha SUBROUTINE set_big(b) BIND(C, name="set_big_") USE, INTRINSIC :: iso_c_binding IMPLICIT NONE REAL(c_double), INTENT(IN) :: b big = b END SUBROUTINE set_big SUBROUTINE set_sml(s) BIND(C, name="set_sml_") USE, INTRINSIC :: iso_c_binding IMPLICIT NONE REAL(c_double), INTENT(IN) :: s sml = s END SUBROUTINE set_sml SUBROUTINE set_eps(e) BIND(C, name="set_eps_") USE, INTRINSIC :: iso_c_binding IMPLICIT NONE REAL(c_double), INTENT(IN) :: e eps = e END SUBROUTINE set_eps SUBROUTINE set_spans(sps) BIND(C, name="set_spans_") USE, INTRINSIC :: iso_c_binding IMPLICIT NONE REAL(c_double), INTENT(IN) :: sps(3) spans = sps END SUBROUTINE set_spans SUBROUTINE set_span(s) BIND(C, name="set_span_") USE, INTRINSIC :: iso_c_binding IMPLICIT NONE REAL(c_double), INTENT(IN) :: s span = s END SUBROUTINE set_span SUBROUTINE set_maxit(m) BIND(C, name="set_maxit_") USE, INTRINSIC :: iso_c_binding IMPLICIT NONE INTEGER(c_int), INTENT(IN) :: m maxit = m END SUBROUTINE set_maxit SUBROUTINE set_nterm(n) BIND(C, name="set_nterm_") USE, INTRINSIC :: iso_c_binding IMPLICIT NONE INTEGER(c_int), INTENT(IN) :: n nterm = n END SUBROUTINE set_nterm END MODULE acedata acepack/src/init.c0000644000176200001440000000271014744022052013537 0ustar liggesusers#include #include // for NULL #include /* .Fortran calls */ extern void F77_NAME(favas)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(mace )(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(set_alpha)(void *); extern void F77_NAME(set_big )(void *); extern void F77_NAME(set_span )(void *); extern void F77_NAME(set_sml )(void *); extern void F77_NAME(set_eps )(void *); extern void F77_NAME(set_spans)(void *); extern void F77_NAME(set_maxit)(void *); extern void F77_NAME(set_nterm)(void *); static const R_FortranMethodDef FortranEntries[] = { {"favas", (DL_FUNC) &F77_NAME(favas), 16}, {"mace", (DL_FUNC) &F77_NAME(mace), 14}, {"set_alpha", (DL_FUNC) &F77_NAME(set_alpha), 1}, {"set_big", (DL_FUNC) &F77_NAME(set_big), 1}, {"set_span", (DL_FUNC) &F77_NAME(set_span), 1}, {"set_sml", (DL_FUNC) &F77_NAME(set_sml), 1}, {"set_eps", (DL_FUNC) &F77_NAME(set_eps), 1}, {"set_spans", (DL_FUNC) &F77_NAME(set_spans), 1}, {"set_maxit", (DL_FUNC) &F77_NAME(set_maxit), 1}, {"set_nterm", (DL_FUNC) &F77_NAME(set_nterm), 1}, {NULL, NULL, 0} }; void R_init_acepack(DllInfo *dll) { R_registerRoutines(dll, NULL, NULL, FortranEntries, NULL); R_useDynamicSymbols(dll, FALSE); } acepack/src/bakfit.f900000644000176200001440000000422714744022052014215 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ SUBROUTINE bakfit(iter,delrsq,rsq,sw,l,z,m,x,ty,tx,w,n,p,np) USE acedata IMPLICIT NONE INTEGER, INTENT(IN) :: n,p,np INTEGER, INTENT(IN) :: iter DOUBLE PRECISION, INTENT(IN) :: delrsq DOUBLE PRECISION, INTENT(INOUT) :: rsq DOUBLE PRECISION, INTENT(IN) :: sw INTEGER, INTENT(IN) :: l(p) DOUBLE PRECISION, INTENT(INOUT) :: z(n,17) INTEGER, INTENT(IN) :: m(n,p) DOUBLE PRECISION, INTENT(IN) :: x(n,p) DOUBLE PRECISION, INTENT(OUT) :: ty(n) DOUBLE PRECISION, INTENT(INOUT) :: tx(n,p) DOUBLE PRECISION, INTENT(IN) :: w(n) DOUBLE PRECISION :: sv, sm, rsqi INTEGER :: nit, i CALL calcmu(n,p,l,z,tx) ty(:) = ty(:) - z(:,10) nit=0 DO rsqi = rsq nit = nit+1 DO i = 1,p IF (l(i) > 0) THEN z(:,1) = ty(m(:,i))+tx(m(:,i),i) z(:,2) = x(m(:,i),i) z(:,7) = w(m(:,i)) CALL smothr(l(i),n,z(1,2),z,z(1,7),z(1,6),z(1,11)) sm = sum(z(:,7)*z(:,6))/sw z(:,6) = z(:,6) - sm sv = 1.0-sum(z(:,7)*(z(:,1)-z(:,6))**2)/sw rsq = sv tx(m(:,i), i) = z(:,6) ty(m(:,i)) = z(:,1) - z(:,6) END IF END DO IF (np == 1 .or. abs(rsq-rsqi) <= delrsq .or. nit >= maxit) EXIT END DO IF (rsq == 0.0 .and. iter == 0) THEN DO i = 1,p IF (l(i) > 0) tx(:,i) = x(:,i) END DO END IF END SUBROUTINE bakfit acepack/src/Makevars0000644000176200001440000000113714745712560014141 0ustar liggesusersall : acedata.o acemod.o bakfit.o calcmu.o ctsub.o favas.o mace.o model.o montne.o rlsmo.o scail.o smooth.o smothr.o sort.o supersmoother.o supsmu.o init.o acedata.o : acedata.f90 acemod.o : acemod.f90 acedata.o bakfit.o : bakfit.f90 acedata.o calcmu.o : calcmu.f90 ctsub.o : ctsub.f90 favas.o : favas.f90 acedata.o mace.o : mace.f90 acedata.o model.o : model.f90 acedata.o montne.o : montne.f90 rlsmo.o : rlsmo.f90 scail.o : scail.f90 smooth.o : smooth.f90 smothr.o : smothr.f90 acedata.o sort.o : sort.f90 supersmoother.o : supersmoother.f90 supsmu.o : supsmu.f90 acedata.o init.o : init.c acepack/src/rlsmo.f900000644000176200001440000000450314744022052014106 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ ! Cross-validation for span selection. ! It evaluates a range of predefined spans selecting the optimal one ! using residual sums of squares ! Cross-validation for span selection. ! It evaluates a range of predefined spans selecting the optimal one ! using residual sums of squares SUBROUTINE rlsmo(x, y, w, span, dof, n, smo, rss, scratch) IMPLICIT NONE INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(IN) :: x(n) DOUBLE PRECISION, INTENT(IN) :: w(n) DOUBLE PRECISION, INTENT(INOUT) :: y(n) ! FIXME: Why is this an INOUT ? DOUBLE PRECISION, INTENT(INOUT) :: span DOUBLE PRECISION, INTENT(OUT) :: dof DOUBLE PRECISION, INTENT(OUT) :: smo(n), rss DOUBLE PRECISION, INTENT(OUT) :: scratch(n) DOUBLE PRECISION :: cvspan(6), cvrss(6), cvmin, penal, s0 INTEGER :: k, idmin cvspan = (/0.3, 0.4, 0.5, 0.6, 0.7, 1.0/) penal = 0.01 cvmin = 1.0d15 idmin = 1 ! Cross-validation for span selection IF (span == 0.0d0) THEN DO k = 1, 6 CALL SuperSmoother(x, y, w, cvspan(k), dof, n, 1, smo, s0, cvrss(k), scratch) IF (cvrss(k) <= cvmin) THEN cvmin = cvrss(k) idmin = k END IF END DO span = cvspan(idmin) IF (penal > 0.0d0) THEN cvmin = (1.0d0 + penal) * cvmin DO k = 6, 1, -1 IF (cvrss(k) <= cvmin) THEN span = cvspan(k) EXIT END IF END DO END IF END IF ! Final smoothing CALL SuperSmoother(x, y, w, span, dof, n, 0, smo, s0, rss, scratch) smo(:) = smo(:) + s0 END SUBROUTINE rlsmo acepack/src/favas.f900000644000176200001440000000675014744022052014060 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ SUBROUTINE favas(p,n,x,y,w,l,delrsq,tx,ty,rsq,ierr,m,z,yspan,iter,iters) USE acedata IMPLICIT NONE INTEGER, INTENT(IN) :: p, n DOUBLE PRECISION, INTENT(IN) :: x(n,p), y(n), w(n) INTEGER, INTENT(IN) :: l(p) DOUBLE PRECISION, INTENT(OUT) :: delrsq, tx(n,p), ty(n), rsq INTEGER, INTENT(OUT) :: ierr, m(n, p) DOUBLE PRECISION, INTENT(OUT) :: z(n, 17), yspan INTEGER, INTENT(OUT) :: iter DOUBLE PRECISION, INTENT(OUT) :: iters(100,2) INTEGER :: pp1, pp2, i, j, k, np, nt DOUBLE PRECISION :: sumlog, tres, rr, rnew, cmn, cmx DOUBLE PRECISION :: ct(10), rss, dof, sm, sv, sw, svx ierr = 0 pp1 = p + 1 pp2 = p + 2 np = COUNT(l(1:p) > 0) sm = sum(w(:)*y(:)) sv = sum(w(:)*y(:)**2) sw = sum(w(:)) z(:,2) = y(:) m(1:n, pp1) = (/(j, j=1,n)/) sm = sm/sw sv = sv/sw-sm**2 sv = 1.0/dsqrt(sv) z(:,1) = (y(:)-sm)*sv CALL sort(z(1,2), m(1,pp1), 1, n) DO i = 1,p IF (l(i) <= 0) CYCLE sm = sum(w(:)*x(:,i))/sw m(1:n, i) = (/(j, j=1,n)/) z(:,2) = x(:,i) CALL sort(z(1,2),m(1,i),1,n) END DO rsq = 0.0 iter = 0 nt = 0 ct(:) = 100.0 ty(:) = z(:, 1) z(:,9) = ty(:) CALL bakfit(iter,delrsq,rsq,sw,l,z,m,x,z(1,9),tx,w,n,p,np) sumlog=0 DO iter = iter +1 IF (l(pp1) /= 4) THEN CALL calcmu(n,p,l,z,tx) DO j=1,n tres=(ty(j)-z(j,10)) IF (abs(tres) < 1e-10) tres=1e-10 z(j,2)=log(sqrt(tres**2)) m(j,pp2)=j END DO CALL sort(z(1,10),m(1,pp2),1,n) DO j=1,n k=m(j,pp2) z(j,4)=z(k,2) z(j,5)=w(k) END DO CALL rlsmo(z(1,10),z(1,4),z(1,5),yspan,dof,n,z(1,6),rss,z(1,7)) DO j=1,n k=m(j,pp2) z(j,7)=exp(-z(j,6)) sumlog=sumlog+n*(w(j)/sw)*2*z(j,6) z(j,8)=ty(k) END DO CALL ctsub(n,z(1,10),z(1,7),z(1,8),z(1,9)) sm = sum(w(:)*z(:,9)) DO j=1,n k=m(j,pp2) ty(k)=z(j,9)-sm/sw END DO sv = sum((w(:)/sw)*ty(:)*ty(:)) svx = sum((w(:)/sw)*z(:,10)*z(:,10)) ty(:) = ty(:)/dsqrt(sv) DO j=1,n DO i=1,p IF (l(i) > 0) tx(j,i)=tx(j,i)/dsqrt(svx) END DO END DO END IF z(:,9) = ty(:) CALL bakfit(iter,delrsq,rsq,sw,l,z,m,x,z(1,9),tx,w,n,p,np) sumlog=sumlog+n*dlog(sv) CALL calcmu(n,p,l,z,tx) rr = sum((w(:)/sw)*(ty(:)-z(:,10))**2) rsq=1-rr rnew=sumlog+rr iters(iter,1)=iter iters(iter,2)=rsq nt = mod(nt,min0(nterm,10))+1 ct(nt) = rsq cmn = MINVAL(ct(1:min0(nterm,10))) cmx = MAXVAL(ct(1:min0(nterm,10))) IF (cmx-cmn <= delrsq .or. iter >= maxit .or. l(pp1)==4) EXIT END DO END SUBROUTINE favasacepack/src/sort.f900000644000176200001440000000676514744022052013755 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ ! Puts into a the permutation vector which sorts v into ! increasing order. Only elements from ii to jj are considered. ! arrays iu(k) and il(k) permit sorting up to 2**(k+1)-1 elements. ! ! This is a modification of CACM algorithm #347 which is a modified ! Hoare's quicksort. ! ! Richard C. Singleton. (1969). Algorithm 347: an efficient algorithm for ! sorting with minimal storage [M1]. _Communications of the ACM_, 23(3), 185-7. ! doi: 10.1145/362875.362901. SUBROUTINE sort (v,a,ii,jj) IMPLICIT NONE INTEGER, INTENT(IN) :: ii, jj DOUBLE PRECISION, INTENT(INOUT) :: v(*) INTEGER, INTENT(INOUT) :: a(jj) INTEGER iu(20), il(20) INTEGER t,tt,ij,j,k,l INTEGER m,i DOUBLE PRECISION vt,vtt LOGICAL continue m=1 i=ii j=jj DO DO IF (i < j) THEN k=i ij=(j+i)/2 t=a(ij) vt=v(ij) IF (v(i) > vt) THEN a(ij)=a(i) a(i)=t t=a(ij) v(ij)=v(i) v(i)=vt vt=v(ij) END IF l=j IF (v(j) < vt) THEN a(ij)=a(j) a(j)=t t=a(ij) v(ij)=v(j) v(j)=vt vt=v(ij) IF (v(i) > vt) THEN a(ij)=a(i) a(i)=t t=a(ij) v(ij)=v(i) v(i)=vt vt=v(ij) END IF END IF DO DO l=l-1 IF (v(l) <= vt) EXIT END DO tt=a(l) vtt=v(l) DO k=k+1 IF (v(k) >= vt) EXIT END DO IF (k > l) EXIT a(l)=a(k) a(k)=tt v(l)=v(k) v(k)=vtt END DO IF (l-i > j-k) THEN il(m)=i iu(m)=l i=k m=m+1 if (j-i > 10) CYCLE IF (i /= ii) EXIT CYCLE END IF il(m)=k iu(m)=j j=l m=m+1 if (j-i > 10) CYCLE IF (i /= ii) EXIT CYCLE END IF m=m-1 IF (m.eq.0) RETURN i=il(m) j=iu(m) IF (j-i > 10) CYCLE IF (i /= ii) EXIT END DO i=i-1 continue = .FALSE. DO i=i+1 IF (i == j) THEN continue = .TRUE. EXIT END IF t=a(i+1) vt=v(i+1) if (v(i).le.vt) CYCLE k=i DO a(k+1)=a(k) v(k+1)=v(k) k=k-1 IF (vt >= v(k)) EXIT END DO a(k+1)=t v(k+1)=vt END DO IF (.not. continue) EXIT END DO END SUBROUTINE sortacepack/src/supersmoother.f900000644000176200001440000001346514744022052015700 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. no representations are made about the ! suitability of this software for any purpose. it is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ SUBROUTINE AddPoint(xin, yin, win, xbar, ybar, cov, var, sumw) IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: xin, yin, win DOUBLE PRECISION, INTENT(INOUT) :: xbar, ybar, cov, var, sumw xbar = (sumw * xbar + xin * win) / (sumw + win) ybar = (sumw * ybar + yin * win) / (sumw + win) cov = cov + win * (xin - xbar) * (yin - ybar) * (sumw + win) / sumw var = var + win * (xin - xbar)**2 * (sumw + win) / sumw sumw = sumw + win END SUBROUTINE AddPoint SUBROUTINE SubtractPoint(xin, yin, win, xbar, ybar, cov, var, sumw) IMPLICIT NONE DOUBLE PRECISION, INTENT(IN) :: xin, yin, win DOUBLE PRECISION, INTENT(INOUT) :: xbar, ybar, cov, var, sumw cov = cov - win * (xin - xbar) * (yin - ybar) * sumw / (sumw - win) var = var - win * (xin - xbar)**2 * sumw / (sumw - win) xbar = (sumw * xbar - win * xin) / (sumw - win) ybar = (sumw * ybar - win * yin) / (sumw - win) sumw = sumw - win END SUBROUTINE SubtractPoint ! Original: https://stacks.stanford.edu/file/druid:gw754yg8889/ORiOn%20003.pdf ! J Friedman, w Stuetzle. Smoothing of Scatterplots, Stanford Project Orion, July 1982 ! This is the smoother used by ACE. SUBROUTINE SuperSmoother(x,y,w,span,dof,n,cross,smo,s0,rss,scratch) IMPLICIT NONE INTEGER, INTENT(IN) :: n ! Number of observations (x,y) DOUBLE PRECISION, INTENT(IN) :: x(n) ! Ordered abscissa values DOUBLE PRECISION, INTENT(INOUT):: y(n) ! Corresponding ordinate (response) values DOUBLE PRECISION, INTENT(IN) :: w(n) ! (optional) Weight for each (x,y) observation DOUBLE PRECISION, INTENT(IN) :: span ! Fractional span for residual smoothing DOUBLE PRECISION, INTENT(OUT) :: dof ! Degrees of freedom INTEGER, INTENT(IN) :: cross ! Cross validation DOUBLE PRECISION, INTENT(OUT) :: smo(n) ! Smoothed ordinate (response) variable DOUBLE PRECISION, INTENT(OUT) :: s0 ! Intercept DOUBLE PRECISION, INTENT(OUT) :: rss ! Residual sum of squares DOUBLE PRECISION, INTENT(INOUT) :: scratch(n) INTEGER :: i, ibnew, ibold, is2, itnew, itold, j, jj, m0, ntie DOUBLE PRECISION :: wt, ispan DOUBLE PRECISION :: sumw, xbar, ybar, cov, var, r INTEGER :: fixeds ! Initialize variables fixeds = 1 xbar = x(1) ybar = y(1) cov = 0.0 var = 0.0 sumw = w(1) IF (span >= 1.0) THEN DO i=2, n CALL AddPoint(x(i), y(i), w(i), xbar, ybar, cov, var, sumw) END DO i = 1 DO WHILE (i <= n) IF (cross == 1) CALL SubtractPoint(x(i), y(i), w(i), xbar, ybar, cov, var, sumw) IF (var <= 0.0) THEN smo(i) = 0.0 ELSE smo(i) = cov * (x(i) - xbar) / var END IF IF (cross == 1) CALL AddPoint(x(i), y(i), w(i), xbar, ybar, cov, var, sumw) i = i + 1 END DO s0 = ybar scratch(1) = cov / var dof = 1.0 rss = sum( (w(:)/sumw) * (y(:) - s0 - smo(:)) ** 2 ) RETURN END IF itold = 1 ibold = 1 dof = -1.0 scratch(:) = y(:) IF (cross == 0) THEN i = 0 DO WHILE (i < n-1) i = i + 1 m0 = i IF (x(i+1) <= x(i)) THEN DO i = i + 1 IF (i >= n) EXIT END DO END IF IF (i == m0) CYCLE ntie = i - m0 + 1 r = 0.0 wt = 0.0 DO jj = m0, i j = jj r = r + y(j) * w(j) wt = wt + w(j) END DO r = r / wt DO j = m0, i y(j) = r END DO END DO END IF ispan = n * span IF (fixeds == 1) THEN is2 = int(ispan / 2) IF (is2 < 1) is2 = 1 END IF DO i = 1, n itnew = min(i + is2, n) ibnew = max(i - is2, 1) DO WHILE (itold < itnew) itold = itold + 1 CALL AddPoint(x(itold), y(itold), w(itold), xbar, ybar, cov, var, sumw) END DO DO WHILE (ibold > ibnew) ibold = ibold - 1 CALL AddPoint(x(ibold), y(ibold), w(ibold), xbar, ybar, cov, var, sumw) END DO DO WHILE (itold > itnew) CALL SubtractPoint(x(itold), y(itold), w(itold), xbar, ybar, cov, var, sumw) itold = itold - 1 END DO DO WHILE (ibold < ibnew) CALL SubtractPoint(x(ibold), y(ibold), w(ibold), xbar, ybar, cov, var, sumw) ibold = ibold + 1 END DO IF (cross == 1) CALL SubtractPoint(x(i), y(i), w(i), xbar, ybar, cov, var, sumw) IF (var <= 0) THEN smo(i) = ybar dof = dof + w(i) / sumw ELSE smo(i) = ybar + cov * (x(i) - xbar) / var dof = dof + w(i) / sumw + (w(i) * (x(i) - xbar) ** 2) / var END IF IF (cross == 1) CALL AddPoint(x(i), y(i), w(i), xbar, ybar, cov, var, sumw) END DO y(:) = scratch(:) IF (cross == 0) THEN i = 0 DO WHILE (i < n-1) i = i + 1 m0 = i DO WHILE (x(i+1) <= x(i) .and. i < n-1) i = i + 1 END DO IF (i /= m0) THEN ntie = i - m0 + 1 wt = SUM(w(m0:i)) r = SUM(smo(m0:i) * w(m0:i))/wt smo(m0:i) = r END IF END DO END IF ybar = sum(w(:)*y(:)) sumw = sum(w(:)) ybar = ybar / sumw smo(:) = smo(:) - ybar s0 = ybar rss = sum( (w(:)/sumw) * (y(:) - s0 - smo(:)) ** 2 ) END SUBROUTINE SuperSmoother acepack/src/mace.f900000644000176200001440000001776014744022052013670 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman, Department of Statistics and ! Stanford Linear Accelerator Center, Stanford University ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ ! Estimate multiple optimal transformations for regression and ! correlation by alternating conditional expectation estimates. ! ! input: ! ! n : number of observations. ! p : number of predictor variables for each observation. ! x(p,n) : predictor data matrix. ! y(n) : response values for the observations. ! missing values are signified by a value (response or ! predictor) greater than or equal to big. ! (see below - default big = 1.0e20) ! w(n) : weights for the observations. ! l(p+1) : flag for each variable. ! l(1) through l(p) : predictor variables. ! l(p+1) : response variable. ! l(i)=0 => ith variable not to be used. ! l(i)=1 => ith variable assumes orderable values. ! l(i)=2 => ith variable assumes circular (periodic) values ! in the range (0.0,1.0) with period 1.0. ! l(i)=3 => ith variable transformation is to be monotone. ! l(i)=4 => ith variable transformation is to be linear. ! l(i)=5 => ith variable assumes categorical (unorderable) values. ! delrsq : termination threshold. iteration stops when ! rsq changes less than delrsq in nterm ! consecutive iterations (see below - default nterm=3). ! ns : number of eigensolutions (sets of transformations). ! ! output: ! ! tx(n,p,ns) : predictor transformations. ! tx(j,i,k) = transformed value of ith predictor for jth obs ! for kth eigensolution. ! ty(n,ns) = response transformations. ! ty(j,k) = transformed response value for jth observation ! for kth eigensolution. ! rsq(ns) = fraction of variance(ty) ! p ! explained by sum tx(i) for each eigensolution. ! i=1 ! ierr : error flag. ! ierr = 0 : no errors detected. ! ierr > 0 : error detected - see format statements below. ! ! scratch: ! ! m(n,p+1), z(n,12) : internal working storage. ! ! Note: mace uses an iterative procedure for solving the optimization ! problem. default starting transformations are ty(j,k)=y(j), ! tx(j,i,k)=x(i,j) : j=1,n, i=1,p, k=1,ns. other starting transformations ! can be specified (if desired) for either the response and/or any of ! the predictor variables. This is signaled by negating the ! corresponding l(i) value and storing the starting transformed ! values in the corresponding array (ty(j,k), tx(j,i,k)) before ! calling mace. ! SUBROUTINE mace (p,n,x,y,w,l,delrsq,ns,tx,ty,rsq,ierr,m,z) USE acedata IMPLICIT NONE ! Inputs INTEGER, INTENT(IN) :: p, n DOUBLE PRECISION, INTENT(IN) :: x(p,n),y(n),w(n) INTEGER, INTENT(IN) :: l(p+1) DOUBLE PRECISION, INTENT(IN) :: delrsq INTEGER, INTENT(IN) :: ns ! Outputs DOUBLE PRECISION, INTENT(OUT) :: tx(n,p,ns), ty(n,ns) DOUBLE PRECISION, INTENT(OUT) :: rsq(ns) INTEGER, INTENT(OUT) :: ierr ! Scratch provided INTEGER, INTENT(OUT) :: m(n,p+1) DOUBLE PRECISION, INTENT(OUT) :: z(n,12) ! Internal Variables INTEGER :: pp1, i,is,ism1,iter,j,js,k,nit,np,nt DOUBLE PRECISION :: rsqi DOUBLE PRECISION :: cmn, cmx DOUBLE PRECISION :: ct(10) DOUBLE PRECISION :: sm,sv,sw,sw1 ierr=0 pp1=p+1 sm=0.0 sv=0.0 sw=0.0 sw1=0.0 IF (any(l(1:pp1) < -5 .or. l(1:pp1) > 5)) THEN ierr = 6 RETURN END IF IF (l(pp1) == 0) THEN ierr=4 RETURN END IF np = count( l /= 0) IF (np <= 0) THEN ierr=5 RETURN END IF sw = sum(w(:)) IF (sw <= 0.0) THEN ierr=1 RETURN END IF DO is=1,ns IF (l(pp1) > 0) ty(:,is)=y(:) DO i=1,p IF (l(i) == 0) THEN tx(:, i, is)=0.0 CYCLE END IF IF (l(i) > 0) THEN tx(:,i,is)=x(i,:) END IF DO j=1,n IF (tx(j,i,is) < big) THEN sm=sm+w(j)*tx(j,i,is) sw1=sw1+w(j) END IF END DO IF (sw1 <= 0.0) THEN tx(:,i,is) = 0.0 sm=0.0 sw1=sm CYCLE END IF sm=sm/sw1 DO j=1,n IF (tx(j,i,is) < big) THEN tx(j,i,is)=tx(j,i,is)-sm ELSE tx(j,i,is)=0.0 END IF END DO sm=0.0 sw1=sm END DO DO j=1,n IF (ty(j,is) < big) THEN sm=sm+w(j)*ty(j,is) sw1=sw1+w(j) END IF END DO IF (sw1 <= 0.0) THEN ierr=1 RETURN END IF sm=sm/sw1 DO j=1,n IF (ty(j,is) < big) THEN ty(j,is)=ty(j,is)-sm ELSE ty(j,is)=0.0 END IF END DO sv = (sv + sum(w(:)*ty(:,is)**2))/sw IF (sv <= 0.0) THEN IF (l(pp1) <= 0) THEN ierr=3 ELSE ierr=2 END IF RETURN END IF sv = 1.0/dsqrt(sv) ty(:,is) = ty(:,is)*sv IF (IS == 1) THEN m(1:n, pp1) = reshape([(i, i=1,n)], shape=[n]) ! 1:n z(:, 2) = y(:) CALL sort (z(1,2),m(1,pp1),1,n) DO i=1,p IF (l(i) /= 0) THEN m(1:n,i) = reshape([(i, i=1,n)], shape=[n]) ! 1:n z(:,2) = x(i,:) CALL sort (z(1,2),m(1,i),1,n) END IF END DO END IF CALL scail (p,n,w,sw,ty(1,is),tx(1,1,is),delrsq,p,z(1,5),z(1,6)) rsq(is)=0.0 iter=0 nt=0 ct(1:min0(nterm,10)) = 100.0 DO ! Until maxit or convergence iter=iter+1 nit=0 DO rsqi=rsq(is) nit=nit+1 DO j=1,n z(j,5)=ty(j,is) DO i=1,p if (l(i).ne.0) z(j,5)=z(j,5)-tx(j,i,is) END DO END DO DO i=1,p IF (l(i) == 0) CYCLE DO j=1,n k=m(j,i) z(j,1)=z(k,5)+tx(k,i,is) z(j,2)=x(i,k) z(j,4)=w(k) END DO CALL smothr (iabs(l(i)),n,z(1,2),z,z(1,4),z(1,3),z(1,6)) sm = sum(z(:,4)*z(:,3))/sw z(:,3) = z(:,3)-sm sv = sum(z(:,4)*(z(:,1)-z(:,3))**2) sv=1.0-sv/sw IF (sv > rsq(is)) THEN rsq(is)=sv DO j=1,n k=m(j,i) tx(k,i,is)=z(j,3) z(k,5)=z(j,1)-z(j,3) END DO END IF END DO IF (np==1 .or. rsq(is)-rsqi <= delrsq .or. nit >= maxit) EXIT END DO DO j=1,n k=m(j,pp1) z(j,2)=y(k) z(j,4)=w(k) z(j,1)=0.0 DO i=1,p if (l(i) /= 0) z(j,1)=z(j,1)+tx(k,i,is) END DO END DO CALL smothr (iabs(l(pp1)),n,z(1,2),z,z(1,4),z(1,3),z(1,6)) IF (is > 1) THEN ism1 = is-1 DO js=1,ism1 sm = sum(w(m(:,pp1))*z(:,3)*ty(m(:,pp1),js))/sw z(:,3) = z(:,3)-sm*ty(m(:,pp1),js) END DO END IF sm=sum(w(m(:,pp1))*z(:,3)) / sw z(m(:,pp1),2)=z(:,1) z(:,3)=z(:,3)-sm sv=sum(z(:,4)*z(:,3)**2) / sw IF (sv <= 0.0) THEN ierr=3 RETURN END IF sv=1.0/dsqrt(sv) ty(m(:,pp1),is)=z(:,3)*sv sv=sum(w(:)*(ty(:,is)-z(:,2))**2) rsq(is)=1.0-sv/sw nt=mod(nt,min0(nterm,10))+1 ct(nt)=rsq(is) cmn = minval(ct(1:min0(nterm, 10))) cmx = maxval(ct(1:min0(nterm, 10))) IF (cmx-cmn <= delrsq .or. iter >= maxit) EXIT END DO END DO END SUBROUTINE mace acepack/src/montne.f900000644000176200001440000000340414744022052014251 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. no representations are made about the ! suitability of this software for any purpose. it is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ SUBROUTINE montne (x,n) IMPLICIT NONE INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(INOUT) :: x(n) DOUBLE PRECISION :: pmn INTEGER :: i,bb,eb,br,er,bl,el bb=0 eb=0 DO WHILE (eb < n) bb=eb+1 eb=bb DO WHILE (eb < n .and. x(bb) == x(eb+1)) eb = eb+1 END DO DO IF (eb < n .or. x(eb) > x(eb+1)) THEN br=eb+1 er=br DO WHILE (er > n .and. x(er+1) == x(br)) er = er+1 END DO pmn=(x(bb)*(eb-bb+1)+x(br)*(er-br+1))/(er-bb+1) eb=er DO i=bb,eb x(i) = pmn END DO END IF IF (bb > 1 .and. x(bb-1) > x(bb)) THEN bl=bb-1 el=bl DO WHILE (bl > 1 .and. x(bl-1) == x(el)) bl=bl-1 END DO pmn=(x(bb)*(eb-bb+1)+x(bl)*(el-bl+1))/(eb-bl+1) bb=bl DO i=bb,eb x(i) = pmn END DO ELSE EXIT END IF END DO END DO END SUBROUTINE montne acepack/src/smooth.f900000644000176200001440000000601714744022052014265 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ ! This is an internal part of the smoother used by AVAS. ! See smothr.f90 and supsmu.90 ! SUBROUTINE smooth (n,x,y,w,span,iper,vsmlsq,smo,acvr) IMPLICIT NONE INTEGER, INTENT(IN) :: n DOUBLE PRECISION, INTENT(IN) :: x(n), y(n), w(n), span INTEGER, INTENT(IN) :: iper DOUBLE PRECISION, INTENT(IN) :: vsmlsq DOUBLE PRECISION, INTENT(OUT) :: smo(n), acvr(n) DOUBLE PRECISION xti,wt,fbw,xm,ym,var,cvar,fbo,tmp,xto,a,h,sy INTEGER in,out,ibw, i,j,j0,it,jper xm = 0.0 ym = 0.0 var = 0.0 cvar = 0.0 fbw = 0.0 jper = iabs(iper) ibw = int(0.5*span*n+0.5) IF (ibw < 2) ibw=2 it = 2*ibw+1 DO i=1,it j=i IF (jper==2) j=i-ibw-1 xti=x(j) IF (j < 1) THEN j=n+j xti=x(j)-1.0 END IF wt=w(j) fbo=fbw fbw=fbw+wt xm=(fbo*xm+wt*xti)/fbw ym=(fbo*ym+wt*y(j))/fbw tmp=0.0 IF (fbo.gt.0.0) tmp=fbw*wt*(xti-xm)/fbo var=var+tmp*(xti-xm) cvar=cvar+tmp*(y(j)-ym) END DO DO j=1,n out = j-ibw-1 in = j+ibw IF (jper == 2 .or. (out >= 1 .and. in <= n)) THEN IF (out < 1) THEN out=n+out xto=x(out)-1.0 xti=x(in) ELSE IF (in > n) THEN in=in-n xti=x(in)+1.0 xto=x(out) ELSE xto=x(out) xti=x(in) END IF wt=w(out) fbo=fbw fbw=fbw-wt tmp=0.0 IF (fbw > 0.0) tmp=fbo*wt*(xto-xm)/fbw var=var-tmp*(xto-xm) cvar=cvar-tmp*(y(out)-ym) xm=(fbo*xm-wt*xto)/fbw ym=(fbo*ym-wt*y(out))/fbw wt=w(in) fbo=fbw fbw=fbw+wt xm=(fbo*xm+wt*xti)/fbw ym=(fbo*ym+wt*y(in))/fbw tmp=0.0 IF (fbo > 0.0) tmp=fbw*wt*(xti-xm)/fbo var=var+tmp*(xti-xm) cvar=cvar+tmp*(y(in)-ym) END IF a = 0.0 IF (var > vsmlsq) a=cvar/var smo(j)=a*(x(j)-xm)+ym IF (iper > 0) THEN h=1.0/fbw IF (var > vsmlsq) h=h+(x(j)-xm)**2/var acvr(j)=abs(y(j)-smo(j))/(1.0-w(j)*h) END IF END DO j=1 DO WHILE (j < n) j0=j sy=smo(j)*w(j) fbw=w(j) DO WHILE (j < n .and. x(j+1) <= x(j)) j=j+1 sy=sy+w(j)*smo(j) fbw=fbw+w(j) END DO IF (j > j0) THEN sy=sy/fbw smo(j0:j) = sy END IF j=j+1 END DO END SUBROUTINE smooth acepack/src/calcmu.f900000644000176200001440000000206514744022052014217 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. no representations are made about the ! suitability of this software for any purpose. it is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ SUBROUTINE calcmu(n,p,l,z,tx) IMPLICIT NONE INTEGER, INTENT(IN) :: n, p, l(p) DOUBLE PRECISION, INTENT(OUT) :: z(n, 17) DOUBLE PRECISION, INTENT(IN) :: tx(n,p) INTEGER :: i z(:,10) = 0.0 DO i=1,p IF (l(i) > 0) z(:,10) = z(:,10) + tx(:,i) END DO END SUBROUTINE calcmu acepack/src/scail.f900000644000176200001440000000612014744022052014042 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ ! 2025-01-02 Shawn Garbett ! Refactored with ChatGPT assistance. ! ! 2016-10-07 Shawn Garbett ! Refactor to insure initialized variable h, and no division by zero. ! ! Note: The original function was named "scale", but this is now part of the ! Fortran 95 namespace. So this was changed to "scail" ! SUBROUTINE scail(p, n, w, sw, ty, tx, eps, maxit, r, sc) IMPLICIT NONE INTEGER, INTENT(IN) :: p, n, maxit DOUBLE PRECISION, INTENT(IN) :: w(n), ty(n), sw, eps DOUBLE PRECISION, INTENT(INOUT) :: tx(n, p) DOUBLE PRECISION, INTENT(OUT) :: r(n), sc(p, 5) INTEGER :: i, j, iter, nit DOUBLE PRECISION :: s, h, t, gamma, delta, v DOUBLE PRECISION :: residual, product ! Initialization sc(:,1) = 0.0 nit = 0 DO nit = nit + 1 ! nit is iteration number ! Store the previous value of sc(i, 1) for convergence check sc(:,5) = sc(:,1) h = 1.0 ! Initialize h to avoid uninitialized variable warning ! Iterate over all steps for the current iteration DO iter = 1, p ! Compute residuals: r(j) = (ty(j) - sum(sc(:,1) * tx(j,:))) * w(j) DO j = 1, n residual = ty(j) - DOT_PRODUCT(sc(:,1), tx(j,:)) r(j) = residual * w(j) END DO ! Update sc(:,2) with the computed values sc(:,2) = -2.0 * (MATMUL(r, tx) / sw) ! Calculate s for next iteration and avoid zero denominator s = SUM(sc(:,2)**2) ! Ensure h gets initialized with s IF (iter == 1 .OR. h <= 0.0) THEN h = s END IF ! If sum of sc(i,2)^2 is zero, exit the loop IF (s <= 0.0) EXIT ! Update sc(:,3) based on gamma and previous values gamma = s / h sc(:,3) = -sc(:,2) + gamma * sc(:,4) h = s ! Calculate new delta and update sc(i,1) and sc(i,4) s = 0.0 t = 0.0 DO j = 1, n product = DOT_PRODUCT(sc(:,3), tx(j,:)) s = s + product * r(j) t = t + w(j) * product**2 END DO delta = s / t ! Update sc(i,1) and sc(i,4) based on delta sc(:,1) = sc(:,1) + delta * sc(:,3) sc(:,4) = sc(:,3) END DO ! Check for convergence v = MAXVAL(ABS(sc(:,1) - sc(:,5))) IF (v < eps .OR. nit >= maxit) EXIT END DO ! Update tx(j,i) based on the final sc(i,1) DO i = 1, p tx(:,i) = sc(i,1) * tx(:,i) END DO RETURN END SUBROUTINE scail acepack/src/smothr.f900000644000176200001440000000526114745712674014311 0ustar liggesusers !---------------------------------------------------------------------------- ! ! This file is part of acepack. ! ! Copyright 1985,2007 Jerome H. Friedman ! Copyright 2016,2025 Shawn Garbett, Vanderbilt University Medical Center ! ! Permission to use, copy, modify, distribute, and sell this software and ! its documentation for any purpose is hereby granted without fee, ! provided that the above copyright notice appear in all copies and that ! both that copyright notice and this permission notice appear in ! supporting documentation. No representations are made about the ! suitability of this software for any purpose. It is provided "as is" ! without express or implied warranty. !______________________________________________________________________________ ! This is the smoother used by AVAS ! ! J Friedman. A Variable Span Smoother. LCS Technical Report No. 5. SLAC ! PUB-3477. November 1984 ! SUBROUTINE smothr (l, n, x, y, w, smo, scratch) USE acedata IMPLICIT NONE INTEGER, INTENT(IN) :: l, n DOUBLE PRECISION, INTENT(IN) :: x(n), y(n), w(n) DOUBLE PRECISION, INTENT(OUT) :: smo(n), scratch(n, 7) DOUBLE PRECISION :: sm, sw, a, b, d INTEGER :: i, j, j0 IF (l >= 5) THEN j=1 DO j0=j sm=w(j)*y(j) sw=w(j) DO WHILE (j < n .and. x(j+1) <= x(j)) j=j+1 sm=sm+w(j)*y(j) sw=sw+w(j) END DO sm=sm/sw smo(j0:j) = sm j=j+1 IF (j > n) RETURN END DO END IF IF (l == 4) THEN sm = sum(w(:)*x(:)*y(:)) sw = sum(w(:)*x(:)**2) b = sum(w(:)*x(:)) d = sum(w(:)) a = sm/(sw-(b**2)/d) b = b/d smo(:) = a*(x(:)-b) RETURN END IF CALL supsmu (n,x,y,w,l,smo,scratch) IF (l /= 3) RETURN scratch(:, 1) = smo scratch(n:-1:1,2) = smo CALL montne (scratch(1,1),n) CALL montne (scratch(1,2),n) sm = sum((smo(:)-scratch(:,1))**2) sw = sum((smo(:)-scratch(n:-1:1,2))**2) IF (sm < sw) THEN smo(:) = scratch(:, 1) ELSE smo(:) = scratch(n:-1:1,2) END IF j=1 DO j0=j DO WHILE (j < n .and. smo(j+1)==smo(j)) j=j+1 END DO IF (j > j0) THEN a = 0.0 IF (j0 > 1) a=0.5*(smo(j0)-smo(j0-1)) b = 0.0 IF (j < n) b=0.5*(smo(j+1)-smo(j)) d = (a+b)/(j-j0) IF (a==0.0 .or. b==0.0) d=2.0*d IF (a==0.0) a=b DO i=j0,j smo(i)=smo(i)-a+d*(i-j0) END DO END IF j=j+1 IF (j > n) EXIT END DO j=1 DO j0=j sm=smo(j) DO WHILE (j < n .and. x(j+1) <= x(j)) j=j+1 sm=sm+smo(j) END DO sm=sm/(j-j0+1) smo(j0:j) = sm j=j+1 if (j.gt.n) RETURN END DO END SUBROUTINE smothr acepack/NAMESPACE0000644000176200001440000000137214753135631013073 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(ace,default) S3method(ace,formula) S3method(avas,default) S3method(avas,formula) S3method(plot,ace) S3method(plot,acetest) S3method(plot,avas) S3method(print,ace) S3method(print,acetest) S3method(print,avas) S3method(summary,ace) S3method(summary,acetest) S3method(summary,avas) export(ace) export(acetest) export(avas) export(set_control) importFrom(grDevices,as.graphicsAnnot) importFrom(grDevices,dev.flush) importFrom(grDevices,dev.hold) importFrom(grDevices,dev.interactive) importFrom(grDevices,devAskNewPage) importFrom(graphics,abline) importFrom(graphics,hist) importFrom(graphics,par) importFrom(stats,cor) importFrom(stats,lm) importFrom(stats,model.frame) useDynLib(acepack, .registration=TRUE) acepack/LICENSE0000644000176200001440000000010414744022052012641 0ustar liggesusersYEAR: 2025, 2007 COPYRIGHT HOLDER: Jerome H. Friedman, Shawn Garbettacepack/NEWS.md0000644000176200001440000000461214753173454012757 0ustar liggesusers# *News* ## 1.6.1 * Date 02-12-2025 * [Fixed bug in weight specification when x was a vector](https:///github.com/vubiostat/acepack/issues/15) * When ierr isn't 0 calls a function that defaults to warning. ## 1.6.0 * Date: 02-05-2025 * [Added independence test using ACE as provided by Holzmann & Klar.](https://github.com/vubiostat/acepack/issues/11) * [Added formula interface to ACE.](https://github.com/vubiostat/acepack/issues/6) * [Added S3 plot/summary/print to ace and AVAS output.](https://github.com/vubiostat/acepack/issues/7) * [Added Checking of ACE error codes.](https://github.com/vubiostat/acepack/issues/13) ## 1.5.2 * Date: 01-27-2025 * [Fixing parallel make build issue and type checking on scratch memory.](https://github.com/vubiostat/acepack/issues/9) ## 1.5.1 * Date: 01-21-2025 * [Fixing errors detected by Ripley in future version of R.](https://github.com/vubiostat/acepack/issues/8) ## 1.5.0 * Date: 01-05-2025 * Complete refactor into F90 assisted by ChatGPT. * Merged all globals to a single parameter set to control routines and provided calls to set them in the FORTRAN. ## 1.4.2 * Date: 03-29-2018 * Updated email address of maintainer. ## 1.4.1 * Date: 10-27-2016 * Converted all routines to "implicit none" by request for Prof Brian Ripley. Added reference ## 1.4.0 * Date: 10-13-2016 * Jonathan Baron (Penn) has transferred maintainer status to Shawn Garbett (Vanderbilt). A shoutout and thanks to Dr. Baron's work for the last several years. ## 1.3.x Older notes. Unknown versions. * 10-6-2016 Shawn Garbett cleaned up fortran6 warnings to maintain CRAN status. Stated precision of exported variables now matches internal computations. An extremely unlikely but possible division by zero path is prevented. * 11-23-2014 Removed non-standard files from top directory. * 4-20-2013 Brian Ripley fixed a Fortran error. * 4-5-2012 Added namespace and removed stray print in avas. * 7-4-2010 Fixed options circ, cat, and mon, in both ace and avas, so that they now can apply to the dependent variable, as specified previously in both the help page and the fortran code. Colin McCullogh did most of the work. Frank Harrell also reported this bug. * Fixed the checks on the options so that they apply to the correct dimension. Previously circ and mon were not working as described. Thanks to Frank Harrell. * Expanded the help pages to make them clearer and provide more examples. --Jon Baron acepack/README.md0000644000176200001440000000305514753142010013120 0ustar liggesusersacepack ======= `acepack` is an [R](https://www.r-project.org) package that provides two nonparametric methods for multiple regression transform selection. The first, Alternating Conditional Expectations (ACE), is an algorithm to find the fixed point of maximal correlation, i.e. it finds a set of transformed response variables that maximizes R^2 using smoothing functions [see Breiman, L., and J.H. Friedman. 1985. "Estimating Optimal Transformations for Multiple Regression and Correlation". Journal of the American Statistical Association. 80:580-598. ]. Also included is the Additivity Variance Stabilization (AVAS) method which works better than ACE when correlation is low [see Tibshirani, R.. 1986. "Estimating Transformations for Regression via Additivity and Variance Stabilization". Journal of the American Statistical Association. 83:394-405. ]. A good introduction to these two methods is in chapter 16 of Frank Harrell's "Regression Modeling Strategies" in the Springer Series in Statistics. History =============== This package is based on public domain S and FORTRAN code for AVAS by Tibshirani, and on FORTRAN code for ACE from Statlib, written by Spector and Friedman. The FORTRAN code has been edited to use double precision, for compatibility with R, and the R code and documentation for ace() have been added by Thomas Lumley, based on that for avas(). Shawn Garbett has refactored with the assistance of ChatGPT to F90 and cleaned up the R interface to current standards. acepack/man/0000755000176200001440000000000014753165207012426 5ustar liggesusersacepack/man/set_control.Rd0000644000176200001440000000466014744022052015244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/set_control.R \name{set_control} \alias{set_control} \title{Set internal parameters that control ACE and AVAS algorithms} \usage{ set_control( alpha = NULL, big = NULL, span = NULL, sml = NULL, eps = NULL, spans = NULL, maxit = NULL, nterm = NULL ) } \arguments{ \item{alpha}{numeric(1); AVAS; Controls high frequency (small span) penalty used with automatic span selection (base tone control). An alpha < 0.0 or alpha > 10.0 results in no effect. Default is 5.0.} \item{big}{numeric(1); ACE and AVAS; a large floating point number. Default is 1.0e30.} \item{span}{numeric(1); ACE and AVAS; Span to use in smoothing represents the fraction of observations in smoothing window. Automatic span selection is performed if set to 0.0. Default is 0.0 (automatic). For small samples (n < 40) or if there are substantial serial correlations between observations close in x - value, then a specified fixed span smoother (span > 0) should be used. Reasonable span values are 0.3 to 0.5.} \item{sml}{numeric(1); AVAS; A small number. Should be set so that `(sml)**(10.0)` does not cause floating point underflow. Default is 1e-30.} \item{eps}{numeric(1); AVAS; Used to numerically stabilize slope calculations for running linear fits.} \item{spans}{numeric(3); AVAS; span values for the three running linear smoothers. \describe{ \item{"spans(1)"}{Tweeter span. Default is 0.05.} \item{"spans(2)"}{Midrange span. Default is 0.2.} \item{"spans(3)"}{Woofer span. Default is 0.5.} } Warning: These span values should be changed only with great care.} \item{maxit}{integer(1); ACE and AVAS; Maximum number of iterations. Default is 20.} \item{nterm}{integer(1); ACE and AVAS; Number of consecutive iterations for which rsq must change less than delcor for convergence. Default is 3.} } \description{ These parameters are used in the smoothing routines of ACE and AVAS. ACE and AVAS both have their own smoothing implementations. This sets them globally for the package. The default values are good for the vast majority of cases. This routine is included to provide complete control to the user, but is rarely needed. } \examples{ set_control(maxit=40) set_control(maxit=20) set_control(alpha=5.0) set_control(big=1e30, sml=1e-30) set_control(eps=1e-3) set_control(span=0.0, spans=c(0.05, 0.2, 0.5)) set_control(maxit=20, nterm=3) } acepack/man/ace.test.Rd0000644000176200001440000000416414753135631014426 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/acetest.R \name{acetest} \alias{acetest} \alias{summary.acetest} \alias{print.acetest} \alias{plot.acetest} \title{ACE permutation test of independence} \usage{ acetest(x, y = NULL, nperm = 999, ...) \method{summary}{acetest}(object, ..., digits) \method{print}{acetest}(x, ...) \method{plot}{acetest}( x, acol = "blue", xlim = c(min(x$tp), max(c(x$tp, ceiling(x$ace * 10)/10))), col = "black", breaks = 100, main = "ACE Correlation Permutations", xlab = bquote(rho(.(x$xname), .(x$yname))), lwd = 2, ... ) } \arguments{ \item{x}{a numeric vector, or a matrix or data frame with two columns. The first column is the 'y' and the second column is the 'x' when calling \code{\link{ace}}.} \item{y}{a vector with same length as x. Default is NULL.} \item{nperm}{number of permutations. Default is 999.} \item{...}{additional arguments to pass to \code{cor}.} \item{object}{S3 object of test results to dispatch.} \item{digits}{Number of significant digits to round for summary.} \item{acol}{for plot; color of the point estimate of correlation} \item{xlim}{for plot;xlimit of histogram} \item{col}{for plot;color of histogram bars} \item{breaks}{for plot;number of breaks. Default to 100.} \item{main}{for plot; main title of plot} \item{xlab}{for plot; x-axis label} \item{lwd}{for plot; line width of point estimate} } \value{ a list containing the following: \itemize{ \item{\code{ace}} The value of the test statistic. \item{\code{pval}} The *p*-value of the test. } } \description{ Performs a permutation test of independence or association. The alternative hypothesis is that x and y are dependent. Code authored by Bernhard Klar, Shawn Garbett. } \examples{ n <- 200 z <- matrix(rnorm(2*n), n) / sqrt(rchisq(n, 2)/2) x <- z[,2]; y <- z[,1] cor.test(x, y, method="spearman") acetest(x, y) plot(acetest(z)) } \references{ Holzmann, H., Klar, B. 2025. "Lancaster correlation - a new dependence measure linked to maximum correlation". Scandinavian Journal of Statistics. 52(1):145-169 } \seealso{ \code{\link{cor}} } acepack/man/ace.Rd0000644000176200001440000001427014753165717013457 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ace.R \name{ace} \alias{ace} \alias{ace.default} \alias{ace.formula} \alias{summary.ace} \alias{print.ace} \alias{plot.ace} \title{Alternating Conditional Expectations} \usage{ ace(...) \method{ace}{default}( x, y, wt = NULL, cat = NULL, mon = NULL, lin = NULL, circ = NULL, delrsq = 0.01, control = NULL, on.error = warning, ... ) \method{ace}{formula}( formula, data = NULL, subset = NULL, na.action = getOption("na.action"), ... ) \method{summary}{ace}(object, ...) \method{print}{ace}(x, ..., digits = 4) \method{plot}{ace}( x, ..., which = 1:(x$p + 1), caption = c(list("Response Y ACE Transformation"), as.list(paste("Carrier", rownames(x$x), "ACE Transformation"))), xlab = "Original", ylab = "Transformed", ask = prod(par("mfcol")) < length(which) && dev.interactive() ) } \arguments{ \item{...}{additional arguments which go ignored for ace call. Included for S3 dispatch consistency. They are utilized when using print as they get passed to cat. Also when plotting an ace object they are passed to plot.} \item{x}{matrix; A matrix containing the independent variables.} \item{y}{numeric; A vector containing the response variable.} \item{wt}{numeric; An optional vector of weights.} \item{cat}{integer; An optional integer vector specifying which variables assume categorical values. Positive values in \code{cat} refer to columns of the \code{x} matrix and zero to the response variable. Variables must be numeric, so a character variable should first be transformed with as.numeric() and then specified as categorical.} \item{mon}{integer; An optional integer vector specifying which variables are to be transformed by monotone transformations. Positive values in \code{mon} refer to columns of the \code{x} matrix and zero to the response variable.} \item{lin}{integer; An optional integer vector specifying which variables are to be transformed by linear transformations. Positive values in \code{lin} refer to columns of the \code{x} matrix and zero to the response variable.} \item{circ}{integer; An integer vector specifying which variables assume circular (periodic) values. Positive values in \code{circ} refer to columns of the \code{x} matrix and zero to the response variable.} \item{delrsq}{numeric(1); termination threshold. Iteration stops when R-squared changes by less than \code{delrsq} in 3 consecutive iterations (default 0.01).} \item{control}{named list; control parameters to set. Documented at \code{\link{set_control}}.} \item{on.error}{function; call back for when ierr is not equal to zero. Defaults to warning.} \item{formula}{formula; an object of class "\code{\link{formula}}": a symbolic description of the model to be smoothed.} \item{data}{an optional data frame, list or environment (or object coercible by \code{\link{as.data.frame}} to a data frame) containing the variables in the model. If not found in data, the variables are taken from \code{environment(formula)}, typically the environment from which \code{ace} is called.} \item{subset}{an optional vector specifying a subset of observations to be used in the fitting process. Only used when a \code{formula} is specified.} \item{na.action}{a function which indicates what should happen when the data contain NAs. The default is set by the \code{na.action} setting of \code{\link{options}}, and is \code{\link{na.fail}} if that is unset. The ‘factory-fresh’ default is \code{\link{na.omit}}. Another possible value is NULL, no action. Value \code{\link{na.exclude}} can be useful.} \item{object}{an S3 ace object} \item{digits}{rounding digits for summary/print} \item{which}{when plotting an ace object which plots to produce.} \item{caption}{a list of captions for a plot.} \item{xlab}{the x-axis label when plotting.} \item{ylab}{the y-axis label when plotting.} \item{ask}{when plotting should the terminal be asked for input between plots.} } \value{ A structure with the following components: \item{x}{the input x matrix.} \item{y}{the input y vector.} \item{tx}{the transformed x values.} \item{ty}{the transformed y values.} \item{rsq}{the multiple R-squared value for the transformed values.} \item{l}{the codes for cat, mon, ...} } \description{ Uses the alternating conditional expectations algorithm to find the transformations of y and x that maximize the proportion of variation in y explained by x. When x is a matrix, it is transformed so that its columns are equally weighted when predicting y. } \examples{ TWOPI <- 8*atan(1) x <- runif(200,0,TWOPI) y <- exp(sin(x)+rnorm(200)/2) a <- ace(x,y) par(mfrow=c(3,1)) plot(a$y,a$ty) # view the response transformation plot(a$x,a$tx) # view the carrier transformation plot(a$tx,a$ty) # examine the linearity of the fitted model # example when x is a matrix X1 <- 1:10 X2 <- X1^2 X <- cbind(X1,X2) Y <- 3*X1+X2 a1 <- ace(X,Y) par(mfrow=c(1,1)) plot(rowSums(a1$tx),a1$y) (lm(a1$y ~ a1$tx)) # shows that the colums of X are equally weighted # From D. Wang and M. Murphy (2005), Identifying nonlinear relationships # regression using the ACE algorithm. Journal of Applied Statistics, # 32, 243-258. X1 <- runif(100)*2-1 X2 <- runif(100)*2-1 X3 <- runif(100)*2-1 X4 <- runif(100)*2-1 # Original equation of Y: Y <- log(4 + sin(3*X1) + abs(X2) + X3^2 + X4 + .1*rnorm(100)) # Transformed version so that Y, after transformation, is a # linear function of transforms of the X variables: # exp(Y) = 4 + sin(3*X1) + abs(X2) + X3^2 + X4 a1 <- ace(cbind(X1,X2,X3,X4),Y) # For each variable, show its transform as a function of # the original variable and the of the transform that created it, # showing that the transform is recovered. par(mfrow=c(2,1)) plot(X1,a1$tx[,1]) plot(sin(3*X1),a1$tx[,1]) plot(X2,a1$tx[,2]) plot(abs(X2),a1$tx[,2]) plot(X3,a1$tx[,3]) plot(X3^2,a1$tx[,3]) plot(X4,a1$tx[,4]) plot(X4,a1$tx[,4]) plot(Y,a1$ty) plot(exp(Y),a1$ty) } \references{ Breiman and Friedman, Journal of the American Statistical Association (September, 1985). The R code is adapted from S code for avas() by Tibshirani, in the Statlib S archive; the FORTRAN is a double-precision version of FORTRAN code by Friedman and Spector in the Statlib general archive. } acepack/man/avas.Rd0000644000176200001440000001366214753164167013663 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/avas.R \name{avas} \alias{avas} \alias{avas.default} \alias{avas.formula} \alias{summary.avas} \alias{print.avas} \alias{plot.avas} \title{Additivity and variance stabilization for regression} \usage{ avas(...) \method{avas}{default}( x, y, wt = NULL, cat = NULL, mon = NULL, lin = NULL, circ = NULL, delrsq = 0.01, yspan = 0, control = NULL, ... ) \method{avas}{formula}( formula, data = NULL, subset = NULL, na.action = getOption("na.action"), ... ) \method{summary}{avas}(object, ...) \method{print}{avas}(x, ..., digits = 4) \method{plot}{avas}( x, ..., which = 1:(x$p + 1), caption = c(list("Response Y AVAS Transformation"), as.list(paste("Carrier", rownames(x$x), "AVAS Transformation"))), xlab = "Original", ylab = "Transformed", ask = prod(par("mfcol")) < length(which) && dev.interactive() ) } \arguments{ \item{...}{additional arguments which go ignored for avas call. Included for S3 dispatch consistency. They are utilized when using print as they get passed to cat. Also when plotting an ace object they are passed to plot.} \item{x}{matrix containing the independent variables.} \item{y}{a vector containing the response variable.} \item{wt}{an optional vector of weights.} \item{cat}{an optional integer vector specifying which variables assume categorical values. Positive values in \code{cat} refer to columns of the \code{x} matrix and zero to the response variable. Variables must be numeric, so a character variable should first be transformed with as.numeric() and then specified} \item{mon}{an optional integer vector specifying which variables are to be transformed by monotone transformations. Positive values in \code{mon} refer to columns of the \code{x} matrix and zero to the response variable.} \item{lin}{an optional integer vector specifying which variables are to be transformed by linear transformations. Positive values in \code{lin} refer to columns of the \code{x} matrix and zero to the response variable.} \item{circ}{an integer vector specifying which variables assume circular (periodic) values. Positive values in \code{circ} refer to columns of the \code{x} matrix and zero to the response variable.} \item{delrsq}{numeric(1); Termination threshold for iteration. Stops when R-squared changes by less than \code{delrsq} in 3 consecutive iterations (default 0.01).} \item{yspan}{yspan Optional window size parameter for smoothing the variance. Range is \eqn{[0,1]}. Default is 0 (cross validated choice). .5 is a reasonable alternative to try.} \item{control}{named list; control parameters to set. Documented at \code{\link{set_control}}.} \item{formula}{formula; an object of class "\code{\link{formula}}": a symbolic description of the model to be smoothed.} \item{data}{an optional data frame, list or environment (or object coercible by \code{\link{as.data.frame}} to a data frame) containing the variables in the model. If not found in data, the variables are taken from \code{environment(formula)}, typically the environment from which \code{ace} is called.} \item{subset}{an optional vector specifying a subset of observations to be used in the fitting process. Only used when a \code{formula} is specified.} \item{na.action}{a function which indicates what should happen when the data contain NAs. The default is set by the \code{na.action} setting of \code{\link{options}}, and is \code{\link{na.fail}} if that is unset. The ‘factory-fresh’ default is \code{\link{na.omit}}. Another possible value is NULL, no action. Value \code{\link{na.exclude}} can be useful.} \item{object}{an S3 ace object} \item{digits}{rounding digits for summary/print} \item{which}{when plotting an ace object which plots to produce.} \item{caption}{a list of captions for a plot.} \item{xlab}{the x-axis label when plotting.} \item{ylab}{the y-axis label when plotting.} \item{ask}{when plotting should the terminal be asked for input between plots.} } \value{ A structure with the following components: \item{x}{the input x matrix.} \item{y}{the input y vector.} \item{tx}{the transformed x values.} \item{ty}{the transformed y values.} \item{rsq}{the multiple R-squared value for the transformed values.} \item{l}{the codes for cat, mon, ...} \item{m}{not used in this version of avas} \item{yspan}{span used for smoothing the variance} \item{iters}{iteration number and rsq for that iteration} \item{niters}{number of iterations used} } \description{ Estimate transformations of \code{x} and \code{y} such that the regression of \code{y} on \code{x} is approximately linear with constant variance } \examples{ TWOPI <- 8*atan(1) x <- runif(200,0,TWOPI) y <- exp(sin(x)+rnorm(200)/2) a <- avas(x,y) plot(a) # View response and carrier transformations plot(a$tx,a$ty) # examine the linearity of the fitted model # From D. Wang and M. Murphy (2005), Identifying nonlinear relationships # regression using the ACE algorithm. Journal of Applied Statistics, # 32, 243-258, adapted for avas. X1 <- runif(100)*2-1 X2 <- runif(100)*2-1 X3 <- runif(100)*2-1 X4 <- runif(100)*2-1 # Original equation of Y: Y <- log(4 + sin(3*X1) + abs(X2) + X3^2 + X4 + .1*rnorm(100)) # Transformed version so that Y, after transformation, is a # linear function of transforms of the X variables: # exp(Y) = 4 + sin(3*X1) + abs(X2) + X3^2 + X4 a1 <- avas(cbind(X1,X2,X3,X4),Y) par(mfrow=c(2,1)) # For each variable, show its transform as a function of # the original variable and the of the transform that created it, # showing that the transform is recovered. plot(X1,a1$tx[,1]) plot(sin(3*X1),a1$tx[,1]) plot(X2,a1$tx[,2]) plot(abs(X2),a1$tx[,2]) plot(X3,a1$tx[,3]) plot(X3^2,a1$tx[,3]) plot(X4,a1$tx[,4]) plot(X4,a1$tx[,4]) plot(Y,a1$ty) plot(exp(Y),a1$ty) } \references{ Rob Tibshirani (1987), ``Estimating optimal transformations for regression''. \emph{Journal of the American Statistical Association} \bold{83}, 394ff. } acepack/DESCRIPTION0000644000176200001440000000563414753301542013363 0ustar liggesusersPackage: acepack Version: 1.6.1 Authors@R: c(person(given = "Phil", family = "Spector", role = "aut"), person(given = "Jerome", family = "Friedman", role = "aut"), person(given = "Robert", family = "Tibshirani", role = "aut"), person(given = "Thomas", family = "Lumley", role = "aut"), person("Shawn", "Garbett", email = "shawn.garbett@vumc.org", comment = c(ORCID="0000-0003-4079-5621"), role = c("cre","aut")), person(given = "Jonathan", family = "Baron", role = "aut"), person("Bernhard", "Klar", email = "bernhard.klar@kit.edu", role = "aut"), person("Scott", "Chasalow", email = "Scott.Chasalow@users.pv.wau.nl", role = "aut") ) Description: Two nonparametric methods for multiple regression transform selection are provided. The first, Alternating Conditional Expectations (ACE), is an algorithm to find the fixed point of maximal correlation, i.e. it finds a set of transformed response variables that maximizes R^2 using smoothing functions [see Breiman, L., and J.H. Friedman. 1985. "Estimating Optimal Transformations for Multiple Regression and Correlation". Journal of the American Statistical Association. 80:580-598. ]. Also included is the Additivity Variance Stabilization (AVAS) method which works better than ACE when correlation is low [see Tibshirani, R. 1986. "Estimating Transformations for Regression via Additivity and Variance Stabilization". Journal of the American Statistical Association. 83:394-405. ]. A good introduction to these two methods is in chapter 16 of Frank Harrell's "Regression Modeling Strategies" in the Springer Series in Statistics. A permutation independence test is included from [Holzmann, H., Klar, B. 2025. "Lancaster correlation - a new dependence measure linked to maximum correlation". Scandinavian Journal of Statistics. 52(1):145-169 ]. Title: ACE and AVAS for Selecting Multiple Regression Transformations License: MIT + file LICENSE Suggests: testthat, roxygen2 Repository: CRAN NeedsCompilation: yes RoxygenNote: 7.3.2 Encoding: UTF-8 Packaged: 2025-02-12 23:34:24 UTC; garbetsp Author: Phil Spector [aut], Jerome Friedman [aut], Robert Tibshirani [aut], Thomas Lumley [aut], Shawn Garbett [cre, aut] (), Jonathan Baron [aut], Bernhard Klar [aut], Scott Chasalow [aut] Maintainer: Shawn Garbett Date/Publication: 2025-02-13 05:30:10 UTC