fANCOVA/0000755000176200001440000000000013753533342011377 5ustar liggesusersfANCOVA/NAMESPACE0000644000176200001440000000125613753344341012621 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(T.L2,default) S3method(T.aov,default) S3method(T.var,default) S3method(plot,fANCOVA) S3method(print,fANCOVA) export(T.L2) export(T.aov) export(T.var) export(loess.ancova) export(loess.as) export(wild.boot) importFrom(graphics,legend) importFrom(graphics,lines) importFrom(graphics,matplot) importFrom(graphics,persp) importFrom(graphics,plot) importFrom(graphics,points) importFrom(stats,coefficients) importFrom(stats,density) importFrom(stats,lm) importFrom(stats,loess) importFrom(stats,model.matrix) importFrom(stats,optimize) importFrom(stats,predict) importFrom(stats,rbinom) importFrom(stats,runif) importFrom(stats,update) fANCOVA/data/0000755000176200001440000000000013753071530012304 5ustar liggesusersfANCOVA/data/USpopu.tab0000644000176200001440000001157311456664252014245 0ustar liggesusers"age" "year" "population" 0 1900 1.811 20 1900 1.5 40 1900 0.917 60 1900 0.391 0 1901 1.85 20 1901 1.53 40 1901 0.94 60 1901 0.401 0 1902 1.892 20 1902 1.563 40 1902 0.963 60 1902 0.409 0 1903 1.93 20 1903 1.595 40 1903 0.985 60 1903 0.418 0 1904 1.969 20 1904 1.628 40 1904 1.008 60 1904 0.426 0 1905 2.01 20 1905 1.665 40 1905 1.032 60 1905 0.437 0 1906 2.05 20 1906 1.699 40 1906 1.056 60 1906 0.447 0 1907 2.086 20 1907 1.733 40 1907 1.077 60 1907 0.457 0 1908 2.125 20 1908 1.769 40 1908 1.101 60 1908 0.467 0 1909 2.162 20 1909 1.804 40 1909 1.127 60 1909 0.48 0 1910 2.203 20 1910 1.839 40 1910 1.154 60 1910 0.493 0 1911 2.227 20 1911 1.851 40 1911 1.176 60 1911 0.507 0 1912 2.25 20 1912 1.861 40 1912 1.2 60 1912 0.521 0 1913 2.279 20 1913 1.875 40 1913 1.229 60 1913 0.538 0 1914 2.305 20 1914 1.887 40 1914 1.259 60 1914 0.556 0 1915 2.317 20 1915 1.887 40 1915 1.283 60 1915 0.572 0 1916 2.325 20 1916 1.886 40 1916 1.308 60 1916 0.589 0 1917 2.329 20 1917 1.876 40 1917 1.334 60 1917 0.606 0 1918 2.332 20 1918 1.771 40 1918 1.358 60 1918 0.623 0 1919 2.299 20 1919 1.824 40 1919 1.369 60 1919 0.634 0 1920 2.277 20 1920 1.855 40 1920 1.417 60 1920 0.65 0 1921 2.362 20 1921 1.881 40 1921 1.448 60 1921 0.665 0 1922 2.413 20 1922 1.904 40 1922 1.471 60 1922 0.676 0 1923 2.433 20 1923 1.947 40 1923 1.499 60 1923 0.692 0 1924 2.476 20 1924 2.005 40 1924 1.527 60 1924 0.712 0 1925 2.46 20 1925 2.047 40 1925 1.551 60 1925 0.733 0 1926 2.366 20 1926 2.085 40 1926 1.578 60 1926 0.752 0 1927 2.305 20 1927 2.128 40 1927 1.608 60 1927 0.775 0 1928 2.251 20 1928 2.171 40 1928 1.639 60 1928 0.796 0 1929 2.142 20 1929 2.209 40 1929 1.677 60 1929 0.811 0 1930 2.181398 20 1930 2.24565 40 1930 1.72142 60 1930 0.823587 0 1931 2.138681 20 1931 2.25853 40 1931 1.765261 60 1931 0.841186 0 1932 2.040919 20 1932 2.272673 40 1932 1.799179 60 1932 0.862443 0 1933 1.93789 20 1933 2.285833 40 1933 1.806959 60 1933 0.890694 0 1934 1.874566 20 1934 2.296708 40 1934 1.792212 60 1934 0.922554 0 1935 1.951444 20 1935 2.303828 40 1935 1.772232 60 1935 0.951288 0 1936 1.944835 20 1936 2.306833 40 1936 1.759353 60 1936 0.974602 0 1937 1.932237 20 1937 2.30758 40 1937 1.753435 60 1937 0.99338 0 1938 2.018652 20 1938 2.323249 40 1938 1.764365 60 1938 1.009094 0 1939 2.041014 20 1939 2.356786 40 1939 1.789868 60 1939 1.023492 0 1940 2.025235 20 1940 2.407683 40 1940 1.82321 60 1940 1.041845 0 1941 2.166858 20 1941 2.429716 40 1941 1.853375 60 1941 1.067457 0 1942 2.325004 20 1942 2.44825 40 1942 1.877565 60 1942 1.084637 0 1943 2.692725 20 1943 2.430035 40 1943 1.905258 60 1943 1.103475 0 1944 2.515859 20 1944 2.386866 40 1944 1.935379 60 1944 1.126025 0 1945 2.463569 20 1945 2.35427 40 1945 1.968557 60 1945 1.154747 0 1946 2.401211 20 1946 2.327077 40 1946 2.007292 60 1946 1.184138 0 1947 3.452304 20 1947 2.285142 40 1947 2.041998 60 1947 1.216288 0 1948 3.169318 20 1948 2.2859 40 1948 2.078552 60 1948 1.250876 0 1949 3.169644 20 1949 2.257371 40 1949 2.115385 60 1949 1.288833 0 1950 3.162567 20 1950 2.258243 40 1950 2.146026 60 1950 1.308533 0 1951 3.315027 20 1951 2.226752 40 1951 2.152206 60 1951 1.327936 0 1952 3.429237 20 1952 2.140294 40 1952 2.196027 60 1952 1.385931 0 1953 3.546301 20 1953 2.059911 40 1953 2.240392 60 1953 1.42497 0 1954 3.670654 20 1954 2.03313 40 1954 2.261167 60 1954 1.435218 0 1955 3.777404 20 1955 2.135741 40 1955 2.281314 60 1955 1.446324 0 1956 3.860003 20 1956 2.114781 40 1956 2.289541 60 1956 1.463365 0 1957 4.035155 20 1957 2.12241 40 1957 2.329121 60 1957 1.466903 0 1958 4.073113 20 1958 2.218649 40 1958 2.368515 60 1958 1.465009 0 1959 4.097383 20 1959 2.247873 40 1959 2.366032 60 1959 1.491951 0 1960 4.093802 20 1960 2.295794 40 1960 2.424758 60 1960 1.525828 0 1961 4.172988 20 1961 2.452277 40 1961 2.468852 60 1961 1.534453 0 1962 4.083751 20 1962 2.620396 40 1962 2.506986 60 1962 1.545564 0 1963 4.01251 20 1963 2.993742 40 1963 2.523791 60 1963 1.568398 0 1964 3.946853 20 1964 2.84674 40 1964 2.513549 60 1964 1.608903 0 1965 3.770049 20 1965 2.828397 40 1965 2.48812 60 1965 1.658851 0 1966 3.555346 20 1966 2.816582 40 1966 2.46545 60 1966 1.71065 0 1967 3.45 20 1967 3.882941 40 1967 2.441744 60 1967 1.763861 0 1968 3.366388 20 1968 3.619894 40 1968 2.409347 60 1968 1.805981 0 1969 3.412562 20 1969 3.642408 40 1969 2.368232 60 1969 1.830333 0 1970 3.508096 20 1970 3.653488 40 1970 2.422721 60 1970 1.91208 0 1971 3.601094 20 1971 3.796605 40 1971 2.304588 60 1971 1.856716 0 1972 3.305565 20 1972 3.895789 40 1972 2.255241 60 1972 1.866721 0 1973 3.128246 20 1973 3.998373 40 1973 2.256186 60 1973 1.897202 0 1974 3.065474 20 1974 4.102553 40 1974 2.225105 60 1974 1.903449 0 1975 3.152345 20 1975 4.187886 40 1975 2.272232 60 1975 1.928253 0 1976 3.115391 20 1976 4.243079 40 1976 2.304558 60 1976 1.901134 0 1977 3.278804 20 1977 4.400497 40 1977 2.331327 60 1977 1.893305 0 1978 3.326388 20 1978 4.417809 40 1978 2.412529 60 1978 1.93722 0 1979 3.426309 20 1979 4.419481 40 1979 2.454323 60 1979 2.020358 fANCOVA/man/0000755000176200001440000000000013753076407012156 5ustar liggesusersfANCOVA/man/USpopu.Rd0000644000176200001440000000173113753344331013674 0ustar liggesusers\name{USpopu} \docType{data} \alias{USpopu} \usage{ data(USpopu) } \title{US national population} \description{ US national population by four groups from 1900 to 1979. The four groups are: Age 0; Age 20; Age 40; Age 60. } \format{A data frame with 320 observations on 3 variables. \tabular{lll}{ \code{age} \tab numeric \tab the group variable of age \cr \code{year} \tab numeric \tab a numeric vector, giving year \cr \code{population} \tab numeric \tab a numeric vector, giving population in millions \cr } } \seealso{ \code{\link{T.L2}}, \code{\link{T.aov}}, \code{\link{T.var}}. } \references{ \url{https://www.census.gov/data/tables/time-series/demo/popest/pre-1980-national.html}, U.S. Census Bureau, National Intercensal Tables: 1900-1990. Last Revised: November 30, 2016 } \examples{ data(USpopu) t1 <- T.L2(USpopu$year, USpopu$population, USpopu$age, degree=2) t1 plot(t1) plot(t1, test.statistic=FALSE, legend.position="topleft") } \keyword{datasets} fANCOVA/man/wild.boot.Rd0000644000176200001440000000403511457461755014353 0ustar liggesusers\name{wild.boot} \alias{wild.boot} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Generate one or multiple bootstrap samples of regression residuals using the wild bootstrap method } \description{ Generate bootstrap samples using the wild bootstrap method introduced by Wu (1986). One of the advantages for the wild bootstrap method is that it allows for a heterogeneous variance in the residuals in regression analysis. } \usage{ wild.boot(x, nboot = 1) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ a vector of regression residuals. } \item{nboot}{ the number of bootstrap replicates. Usually this will be a single positive integer. } } \details{ This function is to generate bootstrap residuals using the wild bootstrap method. } \value{ a vector or a matrix. } \references{ Wu, C. (1986) Jackknife, bootstrap and other resampling methods in regression analysis (with discussion). \emph{Annals of Statistics}. 14, 1261--1350. Mammen, E. (1991). Bootstrap, wild bootstrap, and asymptotic normality. \emph{Probability Theory and Related Fields}. 93, 439--455. } \author{ X.F. Wang \email{wangx6@ccf.org} } \seealso{ \code{\link{T.L2}}, \code{\link{T.aov}}, \code{\link{T.var}}. } \examples{ n <- 1000 x <- runif(n, min=0, max=1) ## generate heteroscedastic error variances sig.x <- sqrt(exp(x)/2.5-0.4) err <- sapply(sig.x, function(x) rnorm(1, sd=x)) x2 <- x^2 y <- 10+3*x+2*x2 +err plot(x,y) fit <- lm(y ~ x + x2) ## obtain 12 samples of the wild bootstrap residuals res.boot <- wild.boot(fit$res, nboot=12) ## obtain 12 samples of the wild bootstrap responses y.boot <- matrix(rep(fit$fit,time=12), ncol=12) + res.boot ## plot the 12 wild bootstrap samples ## The wild bootstrap method keeps the patterns of variance heterogeneity ## in the orginal sample. par(mfrow=c(4,3)) for (i in 1:12) plot(x, y.boot[,i]) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{bootstrap} \keyword{wild bootstrap} \keyword{regression} % __ONLY ONE__ keyword per line fANCOVA/man/T.aov.Rd0000644000176200001440000001077513753103447013441 0ustar liggesusers\name{T.aov} \alias{T.aov} \alias{T.aov.default} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Test the equality of nonparametric curves or surfaces based on an ANOVA-type statistic } \description{ Test the equality of nonparametric curves or surfaces based on an ANOVA-type statistic. The specific model considered here is y_ij= m_i(x_ij) + e_ij, where m_i(.), are nonparametric smooth functions; e_ij are independent identically distributed errors. The errors e_ij do not have to be independent N(0, sigma^2) errors. The errors can be heteroscedastic, i.e., e_ij = sigma_i(x_ij) * u_ij, where u_ij are independent identically distributed errors with mean 0 and variance 1. We are interested in the problem of testing the equality of the regression curves (when x is one-dimensional) or surfaces (when x is two-dimensional), H_0: m_1(.) = m_2(.) = ... v.s. H_1: otherwise The problem can also be viewed as the test of the equality in the one-sample problem for functional data. } \usage{ T.aov(x, ...) \method{T.aov}{default}(x, y, group, B = 200, degree = 1, criterion = c("aicc", "gcv"), family = c("gaussian", "symmetric"), tstat = c("DN", "YB"), user.span = NULL, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ a vector or two-column matrix of covariate values. } \item{y}{ a vector of response values. } \item{group}{ a vector of group indicators that has the same length as y. } \item{B}{ the number of bootstrap replicates. Usually this will be a single positive integer. } \item{degree}{ the degree of the local polynomials to be used. It can ben 0, 1 or 2. } \item{criterion}{ the criterion for automatic smoothing parameter selection: ``aicc'' denotes bias-corrected AIC criterion, ``gcv'' denotes generalized cross-validation. } \item{family}{ if ``gaussian'' fitting is by least-squares, and if ``symmetric'' a re-descending M estimator is used with Tukey's biweight function. } \item{tstat}{ the test statistic used here: if ``DN'' Dette, H., Neumeyer, N. (2001)'s statistic is used; if ``YB'' Young, S.G. and Bowman, A.W. (1995)'s statistic is used. } \item{user.span}{ The user-defined parameter which controls the degree of smoothing. } \item{\dots}{ some control parameters can also be supplied directly } } \details{ A wild bootstrap algorithm is applied to test the equality of nonparametric curves or surfaces based on an ANOVA-type statistic. } \value{ An object of class ``fANCOVA'' } \references{ Dette, H., Neumeyer, N. (2001). Nonparametric analysis of covariance. \emph{Annals of Statistics}. 29, 1361--1400. Young, S.G. and Bowman, A.W. (1995). Nonparametric analysis of covariance. \emph{Biometrics}. 51, 920--931. Wang. X.F. and Ye, D. (2010). On nonparametric comparison of images and regression surfaces. \emph{Journal of Statistical Planning and Inference}. 140, 2875--2884. } \author{ X.F. Wang \email{wangx6@ccf.org} } \seealso{ \code{\link{T.L2}}, \code{\link{T.var}}, \code{\link{loess.as}}, \code{\link{loess.ancova}}. } \examples{ ## Nonparametric test the equality of multiple regression curves ## Simulate data sets n1 <- 100 x1 <- runif(n1,min=0, max=3) sd1 <- 0.2 e1 <- rnorm(n1,sd=sd1) y1 <- sin(2*x1) + e1 n2 <- 100 x2 <- runif(n2, min=0, max=3) sd2 <- 0.25 e2 <- rnorm(n2, sd=sd2) y2 <- sin(2*x2) + 1 + e2 n3 <- 120 x3 <- runif(n3, min=0, max=3) sd3 <- 0.25 e3 <- rnorm(n3, sd=sd3) y3 <- sin(2*x3) + e3 data.bind <- rbind(cbind(x1,y1,1), cbind(x2,y2,2),cbind(x3,y3,3)) data.bind <- data.frame(data.bind) colnames(data.bind)=c('x','y','group') t1 <- T.aov(data.bind$x, data.bind$y, data.bind$group) t1 plot(t1) plot(t1, test.statistic=FALSE) ######## ## Nonparametric test the equality for regression surfaces ## Simulate data sets n1 <- 100 x11 <- runif(n1,min=0, max=3) x12 <- runif(n1,min=0, max=3) sd1 <- 0.2 e1 <- rnorm(n1,sd=sd1) y1 <- sin(2*x11) + sin(2*x12) + e1 n2 <- 100 x21 <- runif(n2, min=0, max=3) x22 <- runif(n2, min=0, max=3) sd2 <- 0.25 e2 <- rnorm(n2, sd=sd2) y2 <- sin(2*x21) + sin(2*x22) + 1 + e2 n3 <- 120 x31 <- runif(n3, min=0, max=3) x32 <- runif(n3, min=0, max=3) sd3 <- 0.25 e3 <- rnorm(n3, sd=sd3) y3 <- sin(2*x31) + sin(2*x32) + e3 data.bind <- rbind(cbind(x11, x12 ,y1,1), cbind(x21, x22, y2,2),cbind(x31, x32,y3,3)) data.bind <- data.frame(data.bind) colnames(data.bind)=c('x1','x2', 'y','group') T.aov(data.bind[,c(1,2)], data.bind$y, data.bind$group) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{nonparametric} \keyword{smooth} \keyword{test the equality} fANCOVA/man/T.L2.Rd0000644000176200001440000001052313753103474013120 0ustar liggesusers\name{T.L2} \alias{T.L2} \alias{T.L2.default} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Test the equality of nonparametric curves or surfaces based on L2 distance } \description{ Test the equality of nonparametric curves or surfaces based on L2 distance. The specific model considered here is y_ij= m_i(x_ij) + e_ij, where m_i(.), are nonparametric smooth functions; e_ij are independent identically distributed errors. The errors e_ij do not have to be independent N(0, sigma^2) errors. The errors can be heteroscedastic, i.e., e_ij = sigma_i(x_ij) * u_ij, where u_ij are independent identically distributed errors with mean 0 and variance 1. We are interested in the problem of testing the equality of the regression curves (when x is one-dimensional) or surfaces (when x is two-dimensional), H_0: m_1(.) = m_2(.) = ... v.s. H_1: otherwise The problem can also be viewed as the test of the equality in the one-sample problem for functional data. } \usage{ T.L2(x, ...) \method{T.L2}{default}(x, y, group, B = 200, degree = 1, criterion = c("aicc", "gcv"), family = c("gaussian", "symmetric"), m = 225, user.span = NULL, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ a vector or two-column matrix of covariate values. } \item{y}{ a vector of response values. } \item{group}{ a vector of group indicators that has the same length as y. } \item{B}{ the number of bootstrap replicates. Usually this will be a single positive integer. } \item{degree}{ the degree of the local polynomials to be used. It can ben 0, 1 or 2. } \item{criterion}{ the criterion for automatic smoothing parameter selection: ``aicc'' denotes bias-corrected AIC criterion, ``gcv'' denotes generalized cross-validation. } \item{family}{ if ``gaussian'' fitting is by least-squares, and if ``symmetric'' a re-descending M estimator is used with Tukey's biweight function. } \item{m}{ the number of the sampling points for the Monte-Carlo integration. } \item{user.span}{ the user-defined parameter which controls the degree of smoothing. } \item{\dots}{ some control parameters can also be supplied directly. } } \details{ A wild bootstrap algorithm is applied to test the equality of nonparametric curves or surfaces based on L2 distance. } \value{ An object of class ``fANCOVA''. } \references{ Dette, H., Neumeyer, N. (2001). Nonparametric analysis of covariance. \emph{Annals of Statistics}. 29, 1361--1400. Wang. X.F. and Ye, D. (2010). On nonparametric comparison of images and regression surfaces. \emph{Journal of Statistical Planning and Inference}. 140, 2875--2884. } \author{ X.F. Wang \email{wangx6@ccf.org} } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{T.aov}}, \code{\link{T.var}}, \code{\link{loess.as}}, \code{\link{loess.ancova}}. } \examples{ ## Nonparametric test the equality of multiple regression curves ## Simulate data sets n1 <- 100 x1 <- runif(n1,min=0, max=3) sd1 <- 0.2 e1 <- rnorm(n1,sd=sd1) y1 <- sin(2*x1) + e1 n2 <- 100 x2 <- runif(n2, min=0, max=3) sd2 <- 0.25 e2 <- rnorm(n2, sd=sd2) y2 <- sin(2*x2) + 1 + e2 n3 <- 120 x3 <- runif(n3, min=0, max=3) sd3 <- 0.25 e3 <- rnorm(n3, sd=sd3) y3 <- sin(2*x3) + e3 data.bind <- rbind(cbind(x1,y1,1), cbind(x2,y2,2),cbind(x3,y3,3)) data.bind <- data.frame(data.bind) colnames(data.bind)=c('x','y','group') t1 <- T.L2(data.bind$x, data.bind$y, data.bind$group, degree=2) t1 plot(t1) plot(t1, test.statistic=FALSE) ######## ## Nonparametric test the equality for regression surfaces ## Simulate data sets n1 <- 100 x11 <- runif(n1,min=0, max=3) x12 <- runif(n1,min=0, max=3) sd1 <- 0.2 e1 <- rnorm(n1,sd=sd1) y1 <- sin(2*x11) + sin(2*x12) + e1 n2 <- 100 x21 <- runif(n2, min=0, max=3) x22 <- runif(n2, min=0, max=3) sd2 <- 0.25 e2 <- rnorm(n2, sd=sd2) y2 <- sin(2*x21) + sin(2*x22) + 1 + e2 n3 <- 120 x31 <- runif(n3, min=0, max=3) x32 <- runif(n3, min=0, max=3) sd3 <- 0.25 e3 <- rnorm(n3, sd=sd3) y3 <- sin(2*x31) + sin(2*x32) + e3 data.bind <- rbind(cbind(x11, x12 ,y1,1), cbind(x21, x22, y2,2),cbind(x31, x32,y3,3)) data.bind <- data.frame(data.bind) colnames(data.bind)=c('x1','x2', 'y','group') T.L2(data.bind[,c(1,2)], data.bind$y, data.bind$group, degree=2) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{nonparametric} \keyword{smooth} \keyword{test the equality} fANCOVA/man/loess.ancova.Rd0000644000176200001440000001215411457455320015035 0ustar liggesusers\name{loess.ancova} \alias{loess.ancova} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Fit a semiparametric ANCOVA model with a local polynomial smoother } \description{ Fit a semiparametric ANCOVA model with a local polynomial smoother. The specific model considered here is y_ij= g_i + m(x_ij) + e_ij, where the parametric part of the model, g_i, is a factor variable; the nonparametric part of the model, m(.), is a nonparametric smooth function; e_ij are independent identically distributed errors. The errors e_ij do not have to be independent N(0, sigma^2) errors. The errors can be heteroscedastic, i.e., e_ij = sigma_i(x_ij) * u_ij, where u_ij are independent identically distributed errors with mean 0 and variance 1. The model is fitted by the direct estimation method (Speckman, 1988), or by the backfitting method (Buja, Hastie and Tibshirani, 1989; Hastie and Tibshirani, 1990). } \usage{ loess.ancova(x, y, group, degree = 2, criterion = c("aicc", "gcv"), family = c("gaussian", "symmetric"), method=c("Speckman", "Backfitting"), iter = 10, tol = 0.01, user.span = NULL, plot = FALSE, data.points = FALSE, legend.position = "topright", ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ a vector or two-column matrix of covariate values. } \item{y}{ a vector of response values. } \item{group}{ a vector of group indicators that has the same length as y. } \item{degree}{ the degree of the local polynomials to be used. It can ben 0, 1 or 2. } \item{criterion}{ the criterion for automatic smoothing parameter selection: ``aicc'' denotes bias-corrected AIC criterion, ``gcv'' denotes generalized cross-validation. } \item{family}{ if ``gaussian'' fitting is by least-squares, and if ``symmetric'' a re-descending M estimator is used with Tukey's biweight function. } \item{method}{ if ``Speckman'' the direct estimation method by Speckman (1988) will be used, and if ``Backfitting'' The model is fitted by the backfitting method (Buja, Hastie and Tibshirani, 1989; Hastie and Tibshirani, 1990). } \item{iter}{ the number of iterations. } \item{tol}{ the number of tolerance in the iterations. } \item{user.span}{ the user-defined parameter which controls the degree of smoothing. If it is not specified, the smoothing parameter will be selected by ``aicc'' or ``gcv'' criterion. } \item{plot}{ if TRUE (when x is one-dimensional), the fitted curves for all groups will be generated; if TRUE (when x is two-dimensional), only the smooth component in the model will be plotted. } \item{data.points}{ if TRUE, the data points will be displayed in the plot. } \item{legend.position}{ the position of legend in the plot: ``topright'', ``topleft'', ``bottomright'', ``bottomleft'', etc. } \item{\dots}{ control parameters. } } \details{ Fit a local polynomial regression with automatic smoothing parameter selection. The predictor x can either one-dimensional or two-dimensional. } \value{ a list of a vector of the parametric estimates and an object of class ``loess''. } \references{ Speckman, P. (1988). Kernel Smoothing in Partial Linear Models. \emph{Journal of the Royal Statistical Society. Series B (Methodological)}, 50, 413--436. Buja, A., Hastie, T. J. and Tibshirani, R. J. (1989). Linear smoothers and additive models (with discussion). \emph{Annals of Statistics}, 17, 453--555. Hastie, T. J. and Tibshirani, R. J. (1990). \emph{Generalized Additive Models}. Vol. 43 of Monographs on Statistics and Applied Probability, Chapman and Hall, London. } \author{ X.F. Wang \email{wangx6@ccf.org} } \seealso{ \code{\link{loess}}. } \examples{ ## Fit semiparametric ANCOVA model set.seed(555) n1 <- 80 x1 <- runif(n1,min=0, max=3) sd1 <- 0.3 e1 <- rnorm(n1,sd=sd1) y1 <- 3*cos(pi*x1/2) + 6 + e1 n2 <- 75 x2 <- runif(n2, min=0, max=3) sd2 <- 0.2 e2 <- rnorm(n2, sd=sd2) y2 <- 3*cos(pi*x2/2) + 3 + e2 n3 <- 90 x3 <- runif(n3, min=0, max=3) sd3 <- 0.3 e3 <- rnorm(n3, sd=sd3) y3 <- 3*cos(pi*x3/2) + e3 data.bind <- rbind(cbind(x1,y1,1), cbind(x2,y2,2),cbind(x3,y3,3)) data.bind <- data.frame(data.bind) colnames(data.bind)=c('x','y','group') x <- data.bind[,1] y <- data.bind[,2] group <- data.bind[,3] loess.ancova(x,y,group, plot=TRUE, data.points=TRUE) ## Fit semiparametric ANCOVA model when the predictor is two-dimensional n1 <- 100 x11 <- runif(n1,min=0, max=3) x12 <- runif(n1,min=0, max=3) sd1 <- 0.2 e1 <- rnorm(n1,sd=sd1) y1 <- sin(2*x11) + sin(2*x12) + e1 n2 <- 100 x21 <- runif(n2, min=0, max=3) x22 <- runif(n2, min=0, max=3) sd2 <- 0.25 e2 <- rnorm(n2, sd=sd2) y2 <- sin(2*x21) + sin(2*x22) + 1 + e2 n3 <- 120 x31 <- runif(n3, min=0, max=3) x32 <- runif(n3, min=0, max=3) sd3 <- 0.25 e3 <- rnorm(n3, sd=sd3) y3 <- sin(2*x31) + sin(2*x32) + 3 + e3 data.bind <- rbind(cbind(x11, x12 ,y1,1), cbind(x21, x22, y2,2),cbind(x31, x32,y3,3)) data.bind <- data.frame(data.bind) colnames(data.bind)=c('x1','x2', 'y','group') loess.ancova(data.bind[,c(1,2)], data.bind$y, data.bind$group, plot=TRUE) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{semiparametric} \keyword{nonparametric} \keyword{smoothing}% __ONLY ONE__ keyword per line fANCOVA/man/plot.fANCOVA.Rd0000644000176200001440000000242413753103432014526 0ustar liggesusers\name{plot.fANCOVA} \alias{plot} \alias{plot.fANCOVA} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Plot a fANCOVA Object } \description{ To plot a fANCOVA object } \usage{ \method{plot}{fANCOVA}(x, test.statistic=TRUE, main="", n=256, legend.position="topright", \dots) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ a fANCOVA object } \item{test.statistic}{ if TRUE, plot the density of the test statistic under null hypothesis; if FALSE, plot the estimated curves. } \item{main}{ the title of the plot } \item{n}{ the number of points that are used to draw the curves or surfaces in the plot. } \item{legend.position}{ the position of legend in the plot: ``topright'', ``topleft'', ``bottomright'', ``bottomleft'', etc. } \item{\dots}{ control parameters of the plot function } } \details{ This function is to plot a fANCOVA object. The plot will be generated only if the predictor x is one-dimensional. if ``test.statistic=TRUE'', a density plot of the test statistic under null hypothesis will be generated; if ``test.statistic=FALSE'', the estimated curves for all groups are drawn. } \author{ X.F. Wang \email{wangx6@ccf.org} } \seealso{ \code{\link{T.L2}}, \code{\link{T.aov}}, \code{\link{T.var}}. } \keyword{ plot } fANCOVA/man/loess.as.Rd0000644000176200001440000000546711457455614014210 0ustar liggesusers\name{loess.as} \alias{loess.as} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Fit a local polynomial regression with automatic smoothing parameter selection } \description{ Fit a local polynomial regression with automatic smoothing parameter selection. Two methods are available for the selection of the smoothing parameter: bias-corrected Akaike information criterion (aicc); and generalized cross-validation (gcv). } \usage{ loess.as(x, y, degree = 1, criterion = c("aicc", "gcv"), family = c("gaussian", "symmetric"), user.span = NULL, plot = FALSE, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ a vector or two-column matrix of covariate values. } \item{y}{ a vector of response values. } \item{degree}{ the degree of the local polynomials to be used. It can ben 0, 1 or 2. } \item{criterion}{ the criterion for automatic smoothing parameter selection: ``aicc'' denotes bias-corrected AIC criterion, ``gcv'' denotes generalized cross-validation. } \item{family}{ if ``gaussian'' fitting is by least-squares, and if ``symmetric'' a re-descending M estimator is used with Tukey's biweight function. } \item{user.span}{ the user-defined parameter which controls the degree of smoothing. } \item{plot}{ if TRUE, the fitted curve or surface will be generated. } \item{\dots}{ control parameters. } } \details{ Fit a local polynomial regression with automatic smoothing parameter selection. The predictor x can either one-dimensional or two-dimensional. } \value{ An object of class ``loess''. } \references{ Cleveland, W. S. (1979) Robust locally weighted regression and smoothing scatterplots. \emph{Journal of the American Statistical Association}. 74, 829--836. Hurvich, C.M., Simonoff, J.S., and Tsai, C.L. (1998), Smoothing Parameter Selection in Nonparametric Regression Using an Improved Akaike Information Criterion. \emph{Journal of the Royal Statistical Society B}. 60, 271--293. Golub, G., Heath, M. and Wahba, G. (1979). Generalized cross validation as a method for choosing a good ridge parameter. \emph{Technometrics}. 21, 215--224. } \author{ X.F. Wang \email{wangx6@ccf.org} } \seealso{ \code{\link{loess}}, \code{\link{loess.ancova}}, \code{\link{T.L2}}, \code{\link{T.aov}}, \code{\link{T.var}}. } \examples{ ## Fit Local Polynomial Regression with Automatic Smoothing Parameter Selection n1 <- 100 x1 <- runif(n1,min=0, max=3) sd1 <- 0.2 e1 <- rnorm(n1,sd=sd1) y1 <- sin(2*x1) + e1 (y1.fit <- loess.as(x1, y1, plot=TRUE)) n2 <- 100 x21 <- runif(n2, min=0, max=3) x22 <- runif(n2, min=0, max=3) sd2 <- 0.25 e2 <- rnorm(n2, sd=sd2) y2 <- sin(2*x21) + sin(2*x22) + 1 + e2 (y2.fit <- loess.as(cbind(x21, x22), y2, plot=TRUE)) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{nonparametric} \keyword{smooth} fANCOVA/man/T.var.Rd0000644000176200001440000001032613753103526013432 0ustar liggesusers\name{T.var} \alias{T.var} \alias{T.var.default} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Test the equality of nonparametric curves or surfaces based on variance estimators } \description{ Test the equality of nonparametric curves or surfaces based on variance estimators. The specific model considered here is y_ij= m_i(x_ij) + e_ij, where m_i(.), are nonparametric smooth functions; e_ij are independent identically distributed errors. The errors e_ij do not have to be independent N(0, sigma^2) errors. The errors can be heteroscedastic, i.e., e_ij = sigma_i(x_ij) * u_ij, where u_ij are independent identically distributed errors with mean 0 and variance 1. We are interested in the problem of testing the equality of the regression curves (when x is one-dimensional) or surfaces (when x is two-dimensional), H_0: m_1(.) = m_2(.) = ... v.s. H_1: otherwise The problem can also be viewed as the test of the equality in the one-sample problem for functional data. } \usage{ T.var(x, ...) \method{T.var}{default}(x, y, group, B = 200, degree = 1, criterion = c("aicc", "gcv"), family = c("gaussian", "symmetric"), user.span = NULL, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ a vector or two-column matrix of covariate values. } \item{y}{ a vector of response values. } \item{group}{ a vector of group indicators that has the same length as y. } \item{B}{ the number of bootstrap replicates. Usually this will be a single positive integer. } \item{degree}{ the degree of the local polynomials to be used. It can ben 0, 1 or 2. } \item{criterion}{ the criterion for automatic smoothing parameter selection: ``aicc'' denotes bias-corrected AIC criterion, ``gcv'' denotes generalized cross-validation. } \item{family}{ if ``gaussian'' fitting is by least-squares, and if ``symmetric'' a re-descending M estimator is used with Tukey's biweight function. } \item{user.span}{ the user-defined parameter which controls the degree of smoothing. } \item{\dots}{ some control parameters can also be supplied directly } } \details{ A wild bootstrap algorithm is applied to test the equality of nonparametric curves or surfaces based on variance estimators. } \value{ An object of class ``fANCOVA''. } \references{ Dette, H., Neumeyer, N. (2001). Nonparametric analysis of covariance. \emph{Annals of Statistics}. 29, 1361--1400. Wang. X.F. and Ye, D. (2010). On nonparametric comparison of images and regression surfaces. \emph{Journal of Statistical Planning and Inference}. 140, 2875--2884. } \author{ X.F. Wang \email{wangx6@ccf.org} } \seealso{ \code{\link{T.L2}}, \code{\link{T.aov}}, \code{\link{loess.as}}, \code{\link{loess.ancova}}. } \examples{ ## Nonparametric test the equality of multiple regression curves ## Simulate data sets n1 <- 100 x1 <- runif(n1,min=0, max=3) sd1 <- 0.2 e1 <- rnorm(n1,sd=sd1) y1 <- sin(2*x1) + e1 n2 <- 100 x2 <- runif(n2, min=0, max=3) sd2 <- 0.25 e2 <- rnorm(n2, sd=sd2) y2 <- sin(2*x2) + 1 + e2 n3 <- 120 x3 <- runif(n3, min=0, max=3) sd3 <- 0.25 e3 <- rnorm(n3, sd=sd3) y3 <- sin(2*x3) + e3 data.bind <- rbind(cbind(x1,y1,1), cbind(x2,y2,2),cbind(x3,y3,3)) data.bind <- data.frame(data.bind) colnames(data.bind)=c('x','y','group') t1 <- T.var(data.bind$x, data.bind$y, data.bind$group, degree=2, criterion="gcv") t1 plot(t1) plot(t1, test.statistic=FALSE) ######## ## Nonparametric test the equality for regression surfaces ## Simulate data sets n1 <- 100 x11 <- runif(n1,min=0, max=3) x12 <- runif(n1,min=0, max=3) sd1 <- 0.2 e1 <- rnorm(n1,sd=sd1) y1 <- sin(2*x11) + sin(2*x12) + e1 n2 <- 100 x21 <- runif(n2, min=0, max=3) x22 <- runif(n2, min=0, max=3) sd2 <- 0.25 e2 <- rnorm(n2, sd=sd2) y2 <- sin(2*x21) + sin(2*x22) + 1 + e2 n3 <- 120 x31 <- runif(n3, min=0, max=3) x32 <- runif(n3, min=0, max=3) sd3 <- 0.25 e3 <- rnorm(n3, sd=sd3) y3 <- sin(2*x31) + sin(2*x32) + e3 data.bind <- rbind(cbind(x11, x12 ,y1,1), cbind(x21, x22, y2,2),cbind(x31, x32,y3,3)) data.bind <- data.frame(data.bind) colnames(data.bind)=c('x1','x2', 'y','group') T.var(data.bind[,c(1,2)], data.bind$y, data.bind$group) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{nonparametric} \keyword{smooth} \keyword{test the equality} fANCOVA/DESCRIPTION0000644000176200001440000000215413753533342013107 0ustar liggesusersPackage: fANCOVA Title: Nonparametric Analysis of Covariance Version: 0.6-1 Authors@R: c( person(given = "Xiaofeng", family = "Wang", role = c("aut", "cre"), email = "wangx6@ccf.org"), person(given = "Xinge", family = "Ji", role = c("ctb"), email = "jix@ccf.org")) Description: A collection of R functions to perform nonparametric analysis of covariance for regression curves or surfaces. Testing the equality or parallelism of nonparametric curves or surfaces is equivalent to analysis of variance (ANOVA) or analysis of covariance (ANCOVA) for one-sample functional data. Three different testing methods are available in the package, including one based on L-2 distance, one based on an ANOVA statistic, and one based on variance estimators. License: GPL-3 Encoding: UTF-8 LazyData: true RoxygenNote: 7.1.1 NeedsCompilation: no Packaged: 2020-11-12 23:45:18 UTC; jix Author: Xiaofeng Wang [aut, cre], Xinge Ji [ctb] Maintainer: Xiaofeng Wang Repository: CRAN Date/Publication: 2020-11-13 16:40:02 UTC fANCOVA/NEWS0000644000176200001440000000043713753100225012070 0ustar liggesusersWhat's new? This package contains a collection of functions to perform nonparametric analysis of covariance for regression curves or surfaces. By using the package, one can test the equality of multiple functional curves or surfaces. Wild-bootstrap algorithm is applied in the package. fANCOVA/R/0000755000176200001440000000000013753077341011602 5ustar liggesusersfANCOVA/R/zzz.R0000644000176200001440000000013413753073102012547 0ustar liggesusers.onAttach <- function(libname, pkgname) { packageStartupMessage("fANCOVA 0.6-1 loaded") } fANCOVA/R/fANOVA_all.R0000644000176200001440000012477713753103765013611 0ustar liggesusers#' @importFrom stats coefficients density lm loess model.matrix optimize predict rbinom runif update #' @importFrom graphics legend lines matplot persp plot points ## Wild Bootstrap #' @export wild.boot <- function(x, nboot=1){ if (!is.numeric(x)) stop("argument 'x' must be numeric") x <- as.vector(x) nx <- length(x) if (nboot < 1) stop("'nboot' has to be greater than zero") if (nboot==1) { a <- rbinom(nx,1,prob=(5+sqrt(5))/10) w <- (1-sqrt(5))/2*a+(1+sqrt(5))/2*(1-a) x.wb <- w*x return(x.wb) } if (nboot >1 ){ a0 <- as.matrix(rep(nx, times= nboot)) a <- apply(a0, 1, function(x) {rbinom(x,1,prob=(5+sqrt(5))/10)}) w <- (1-sqrt(5))/2*a+(1+sqrt(5))/2*(1-a) x.wb <- w*x return(x.wb) } } ## loess with Automatic Smoothing Parameter Selection #' @export loess.as <- function(x, y, degree=1, criterion=c("aicc", "gcv"), family = c("gaussian", "symmetric"), user.span=NULL, plot=FALSE, ...) { criterion <- match.arg(criterion) family <- match.arg(family) x <- as.matrix(x) if ((ncol(x) != 1) & (ncol(x) != 2)) stop("The predictor 'x' should be one or two dimensional!!") if (!is.numeric(x)) stop("argument 'x' must be numeric!") if (!is.numeric(y)) stop("argument 'y' must be numeric!") if (any(is.na(x))) stop("'x' contains missing values!") if (any(is.na(y))) stop("'y' contains missing values!") if (!is.null(user.span) && (length(user.span) != 1 || !is.numeric(user.span))) stop("argument 'user.span' must be a numerical number!") if(nrow(x) != length(y)) stop("'x' and 'y' have different lengths!") if(length(y) < 3) stop("not enough observations!") data.bind <- data.frame(x=x, y=y) if (ncol(x) == 1) { names(data.bind) <- c("x", "y") } else { names(data.bind) <- c("x1", "x2", "y") } opt.span <- function(model, criterion=c("aicc", "gcv"), span.range=c(.05, .95)){ as.crit <- function (x) { span <- x$pars$span traceL <- x$trace.hat sigma2 <- sum(x$residuals^2 ) / (x$n-1) aicc <- log(sigma2) + 1 + 2* (2*(traceL+1)) / (x$n-traceL-2) gcv <- x$n*sigma2 / (x$n-traceL)^2 result <- list(span=span, aicc=aicc, gcv=gcv) return(result) } criterion <- match.arg(criterion) fn <- function(span) { mod <- update(model, span=span) as.crit(mod)[[criterion]] } result <- optimize(fn, span.range) return(list(span=result$minimum, criterion=result$objective)) } if (ncol(x)==1) { if (is.null(user.span)) { fit0 <- loess(y ~ x, degree=degree, family = family, data=data.bind, ...) span1 <- opt.span(fit0, criterion=criterion)$span } else { span1 <- user.span } fit <- loess(y ~ x, degree=degree, span=span1, family = family, data=data.bind, ...) } else { if (is.null(user.span)) { fit0 <- loess(y ~ x1 + x2, degree=degree,family = family, data.bind, ...) span1 <- opt.span(fit0, criterion=criterion)$span } else { span1 <- user.span } fit <- loess(y ~ x1 + x2, degree=degree, span=span1, family = family, data=data.bind,...) } if (plot){ if (ncol(x)==1) { m <- 100 x.new <- seq(min(x), max(x), length.out=m) fit.new <- predict(fit, data.frame(x = x.new)) plot(x, y, col="lightgrey", xlab="x", ylab="m(x)", ...) lines(x.new,fit.new, lwd=1.5, ...) } else { m <- 50 x1 <- seq(min(data.bind$x1), max(data.bind$x1), len=m) x2 <- seq(min(data.bind$x2), max(data.bind$x2), len=m) x.new <- expand.grid(x1=x1, x2=x2) fit.new <- matrix(predict(fit, x.new), m, m) persp(x1, x2, fit.new, theta=40, phi=30, ticktype="detailed", xlab="x1", ylab="x2", zlab="y", col="lightblue", expand=0.6) } } return(fit) } ## Fit a semiparametric ANCOVA model #' @export loess.ancova <- function(x, y, group, degree=2, criterion=c("aicc", "gcv"), family = c("gaussian", "symmetric"), method=c("Speckman", "Backfitting"), iter = 10, tol =0.01, user.span= NULL, plot = FALSE, data.points=FALSE, legend.position = "topright", ...) { criterion <- match.arg(criterion) family <- match.arg(family) method <- match.arg(method) x <- as.matrix(x) if ((ncol(x) != 1) & (ncol(x) != 2)) stop("The predictor 'x' should be one or two dimensional!!") if (!is.numeric(x)) stop("argument 'x' must be numeric!") if (!is.numeric(y)) stop("argument 'y' must be numeric!") if (any(is.na(x))) stop("'x' contains missing values!") if (any(is.na(y))) stop("'y' contains missing values!") if (any(is.na(group))) stop("'group' contains missing values!") if(nrow(x) != length(y)) stop("'x' and 'y' have different lengths!") if(nrow(x) != length(y) | nrow(x) != length(group)) stop("'x', 'y' and 'group' have different lengths!") g <- unique(group) gn <- length(g) ny <- length(y) if(gn > ny/3) stop("check if there is error in the 'group' variable!") if(ny < 3*gn) stop("not enough observations!") group <- as.factor(group) data.bind <- data.frame(x=x, y=y, group=group) if (ncol(x) == 1) { names(data.bind) <- c("x", "y", "group") } else { names(data.bind) <- c("x1", "x2", "y", "group") } opt.span <- function(model, criterion=c("aicc", "gcv"), span.range=c(.05, .95)){ as.crit <- function (x) { span <- x$pars$span traceL <- x$trace.hat sigma2 <- sum(x$residuals^2 ) / (x$n-1) aicc <- log(sigma2) + 1 + 2* (2*(traceL+1)) / (x$n-traceL-2) gcv <- x$n*sigma2 / (x$n-traceL)^2 result <- list(span=span, aicc=aicc, gcv=gcv) return(result) } criterion <- match.arg(criterion) fn <- function(span) { mod <- update(model, span=span) as.crit(mod)[[criterion]] } result <- optimize(fn, span.range) return(list(span=result$minimum, criterion=result$objective)) } loc.hatmat1 <- function(x, ...){ x <- as.matrix(x) y <- diag(nrow(x)) ploess1 <- function(y, ...) predict(loess(y ~ x, ...)) H.hat <- apply(y, 2, ploess1, ...) return(H.hat) } loc.hatmat2 <- function(x, ...){ x <- as.matrix(x) y <- diag(nrow(x)) ploess2 <- function(y, ...) predict(loess(y ~ x[,1] +x[,2], ...)) H.hat <- apply(y, 2, ploess2, ...) return(H.hat) } if (method == "Speckman"){ if (ncol(x)==1) { if (is.null(user.span)) { x.ord <- order(data.bind$x) data.bind2 <- data.bind[x.ord,] mod.lm <- lm(y~group, data=data.bind2) lm.hatMat <- model.matrix(mod.lm) mod.sm0 <- loess(mod.lm$res ~ data.bind2$x, degree=degree,family = family, ...) span1 <- opt.span(mod.sm0, criterion=criterion)$span sm.hatMat <- loc.hatmat1(data.bind2$x, degree=degree,family = family, span=span1, ...) N <- nrow(lm.hatMat) IS <- t(diag(N) - sm.hatMat) X.tilde <- IS %*% lm.hatMat y.tilde <- IS %*% data.bind2$y qx <- qr(X.tilde) lm.coeff <- solve(qx, y.tilde) #df <- nrow(X.tilde)-ncol(X.tilde) #sigma2 <- sum((y.tilde - X.tilde%*%lm.coeff)^2)/df #lm.se <- sqrt(diag(sigma2 * chol2inv(qx$qr))) lm.fit <- lm.hatMat %*% lm.coeff lm.fit2 <- lm.fit[order(x.ord),] lm.res <- y - lm.fit2 mod.sm <- loess(lm.res ~ x, degree=degree, family = family, span=span1, ...) } else { x.ord <- order(data.bind$x) data.bind2 <- data.bind[x.ord,] mod.lm <- lm(y~group, data=data.bind2) lm.hatMat <- model.matrix(mod.lm) span1 <- user.span sm.hatMat <- loc.hatmat1(data.bind2$x, degree=degree,family = family, span=span1, ...) N <- nrow(lm.hatMat) IS <- t(diag(N) - sm.hatMat) X.tilde <- IS %*% lm.hatMat y.tilde <- IS %*% data.bind2$y qx <- qr(X.tilde) lm.coeff <- solve(qx, y.tilde) lm.fit <- lm.hatMat %*% lm.coeff lm.fit2 <- lm.fit[order(x.ord),] lm.res <- y - lm.fit2 mod.sm <- loess(lm.res ~ x, degree=degree, family = family, span=span1, ...) } } else { if (is.null(user.span)) { x.ord <- order(data.bind$x1) data.bind2 <- data.bind[x.ord,] mod.lm <- lm(y~group, data=data.bind2) lm.hatMat <- model.matrix(mod.lm) mod.sm0 <- loess(mod.lm$res ~ data.bind2$x1 + data.bind2$x2, degree=degree,family = family, ...) span1 <- opt.span(mod.sm0, criterion=criterion)$span sm.hatMat <- loc.hatmat2(cbind(data.bind2$x1, data.bind2$x2) , degree=degree,family = family, span=span1, ...) N <- nrow(lm.hatMat) IS <- t(diag(N) - sm.hatMat) X.tilde <- IS %*% lm.hatMat y.tilde <- IS %*% data.bind2$y qx <- qr(X.tilde) lm.coeff <- solve(qx, y.tilde) lm.fit <- lm.hatMat %*% lm.coeff lm.fit2 <- lm.fit[order(x.ord),] lm.res <- y - lm.fit2 x1 <- data.bind$x1; x2 <- data.bind$x2 mod.sm <- loess(lm.res ~ x1 + x2, degree=degree, family = family, span=span1, ...) } else { x.ord <- order(data.bind$x1) data.bind2 <- data.bind[x.ord,] mod.lm <- lm(y~group, data=data.bind2) lm.hatMat <- model.matrix(mod.lm) span1 <- user.span sm.hatMat <- loc.hatmat2(cbind(data.bind2$x1, data.bind2$x2) , degree=degree,family = family, span=span1, ...) N <- nrow(lm.hatMat) IS <- t(diag(N) - sm.hatMat) X.tilde <- IS %*% lm.hatMat y.tilde <- IS %*% data.bind2$y qx <- qr(X.tilde) lm.coeff <- solve(qx, y.tilde) lm.fit <- lm.hatMat %*% lm.coeff lm.fit2 <- lm.fit[order(x.ord),] lm.res <- y - lm.fit2 x1 <- data.bind$x1; x2 <- data.bind$x2 mod.sm <- loess(lm.res ~ x1 + x2, degree=degree, family = family, span=span1, ...) } } } else { if (ncol(x)==1) { if (is.null(user.span)) { mod.lm <- lm(y~group) mod.sm0 <- loess(mod.lm$res ~ x, degree=degree,family = family, ...) span1 <- opt.span(mod.sm0, criterion=criterion)$span mod.sm <- loess(mod.lm$res ~ x, degree=degree,family = family, span=span1, ...) for (i in 1:iter){ lm.temp <- mod.lm mod.lm <- lm((y-mod.sm$fit)~group) mod.sm0 <- loess(mod.lm$res ~ x, degree=degree,family = family, ...) span1 <- opt.span(mod.sm0, criterion=criterion)$span mod.sm <- loess(mod.lm$res ~ x, degree=degree,family = family, span=span1, ...) diff <- min(abs(coefficients(mod.lm)- coefficients(lm.temp))) if (diff< tol) break } lm.coeff <- coefficients(mod.lm) } else { span1 <- user.span mod.lm <- lm(y~group) mod.sm <- loess(mod.lm$res ~ x, degree=degree,family = family, span=span1, ...) for (i in 1:iter){ lm.temp <- mod.lm mod.lm <- lm((y-mod.sm$fit)~group) mod.sm <- loess(mod.lm$res ~ x, degree=degree,family = family, span=span1, ...) diff <- min(abs(coefficients(mod.lm)- coefficients(lm.temp))) if (diff< tol) break } lm.coeff <- coefficients(mod.lm) } } else { if (is.null(user.span)) { mod.lm <- lm(y~group) x1 <- data.bind$x1; x2 <- data.bind$x2 mod.sm0 <- loess(mod.lm$res ~ x1 + x2, degree=degree,family = family, ...) span1 <- opt.span(mod.sm0, criterion=criterion)$span mod.sm <- loess(mod.lm$res ~ x1 + x2, degree=degree,family = family, span=span1, ...) for (i in 1:iter){ lm.temp <- mod.lm mod.lm <- lm((y-mod.sm$fit)~group) mod.sm0 <- loess(mod.lm$res ~ x1 + x2, degree=degree,family = family, ...) span1 <- opt.span(mod.sm0, criterion=criterion)$span mod.sm <- loess(mod.lm$res ~ x1 + x2, degree=degree,family = family, span=span1, ...) diff <- min(abs(coefficients(mod.lm)- coefficients(lm.temp))) if (diff< tol) break } lm.coeff <- coefficients(mod.lm) } else { span1 <- user.span mod.lm <- lm(y~group) x1 <- data.bind$x1; x2 <- data.bind$x2 mod.sm <- loess(mod.lm$res ~ x1 + x2, degree=degree,family = family, span=span1, ...) for (i in 1:iter){ lm.temp <- mod.lm mod.lm <- lm((y-mod.sm$fit)~group) mod.sm <- loess(mod.lm$res ~ x1 + x2, degree=degree,family = family, span=span1, ...) diff <- min(abs(coefficients(mod.lm)- coefficients(lm.temp))) if (diff< tol) break } lm.coeff <- coefficients(mod.lm) } } } if (plot){ if (ncol(x)==1) { u.min <- max(tapply(x, group, min)) u.max <- min(tapply(x, group, max)) m <- 100 u <- seq(from=u.min, to=u.max, length.out=m) fit.new <- predict(mod.sm, data.frame(x = u)) coef.lm <- lm.coeff coef.lm0 <- rep(lm.coeff[1], time=length(coef.lm)) coef.lm0[1] <- 0 lm.est <- matrix(rep(coef.lm+coef.lm0, each=m), ncol=gn) sm.est <- matrix(rep(fit.new, times=gn), ncol=gn) est <- lm.est + sm.est matplot(u, est, lty=1:gn, col=1:gn, type="l", lwd=1.5, xlab="x", ylab="m(x)", xlim=c(min(x), max(x)), ylim=c(min(y), max(y))) if (data.points) points(x,y, col="lightgray") text <- paste("group", 1:gn, sep="") legend(x = legend.position, legend = text, lty=1:gn, col=1:gn, lwd=1.5) } else { u1.min <- max(tapply(x[,1], group, min)) u1.max <- min(tapply(x[,1], group, max)) u2.min <- max(tapply(x[,2], group, min)) u2.max <- min(tapply(x[,2], group, max)) m <- 50 u1 <- seq(u1.min, u1.max, len=m) u2 <- seq(u2.min, u2.max, len=m) u.new <- expand.grid(x1=u1, x2=u2) fit.new <- matrix(predict(mod.sm, u.new), m, m) persp(u1, u2, fit.new, theta=40, phi=30, ticktype="detailed", xlab="x1", ylab="x2", zlab="y", col="lightblue", expand=0.6) } } return(list(linear.fit=lm.coeff, smooth.fit=mod.sm)) } ##-------------------------------------------------------------- ## Test the equality of curves based on L2 distance #' @export T.L2 <- function(x, ...) UseMethod("T.L2") #' @export T.L2.default <- function(x, y, group, B=200, degree=1, criterion=c("aicc", "gcv"), family = c("gaussian", "symmetric"), m=225, user.span=NULL, ...) { criterion <- match.arg(criterion) family <- match.arg(family) x <- as.matrix(x) if (ncol(x) == 1) { method <- "Test the equality of curves based on L2 distance" } else { if(ncol(x) == 2) { method <- "Test the equality of surfaces based on L2 distance" } else stop("The predictor 'x' should be one or two dimensional!!") } ## CheckValidity if (!is.numeric(x)) stop("argument 'x' must be numeric!") if (!is.numeric(y)) stop("argument 'y' must be numeric!") if (any(is.na(x))) stop("'x' contains missing values!") if (any(is.na(y))) stop("'y' contains missing values!") if (any(is.na(group))) stop("'group' contains missing values!") if (!is.null(user.span) && (length(user.span) != 1 || !is.numeric(user.span))) stop("argument 'user.span' must be a numerical number!") if(nrow(x) != length(y) | nrow(x) != length(group)) stop("'x', 'y' and 'group' have different lengths!") g <- unique(group) gn <- length(g) ny <- length(y) if(gn > ny/3) stop("check if there is error in the 'group' variable!") if(ny < 3*gn) stop("not enough observations!") data.bind <- data.frame(x=x, y=y, group=group) if (ncol(x) == 1) { names(data.bind) <- c("x", "y", "group") } else { names(data.bind) <- c("x1", "x2", "y", "group") } opt.span <- function(model, criterion=c("aicc", "gcv"), span.range=c(.05, .95)){ as.crit <- function (x) { span <- x$pars$span traceL <- x$trace.hat sigma2 <- sum(x$residuals^2 ) / (x$n-1) aicc <- log(sigma2) + 1 + 2* (2*(traceL+1)) / (x$n-traceL-2) gcv <- x$n*sigma2 / (x$n-traceL)^2 result <- list(span=span, aicc=aicc, gcv=gcv) return(result) } criterion <- match.arg(criterion) fn <- function(span) { mod <- update(model, span=span) as.crit(mod)[[criterion]] } result <- optimize(fn, span.range) return(list(span=result$minimum, criterion=result$objective)) } loc.fit.sub <- function(g, data, dim=c("one", "two"), degree=1, criterion=c("aicc", "gcv"), family = c("gaussian", "symmetric"), user.span=NULL, ...){ dim <- match.arg(dim) opt.span.sub <- function(model, criterion=c("aicc", "gcv"), span.range=c(.05, .95)){ as.crit <- function (x) { span <- x$pars$span traceL <- x$trace.hat sigma2 <- sum(x$residuals^2 ) / (x$n-1) aicc <- log(sigma2) + 1 + 2* (2*(traceL+1)) / (x$n-traceL-2) gcv <- x$n*sigma2 / (x$n-traceL)^2 result <- list(span=span, aicc=aicc, gcv=gcv) return(result) } criterion <- match.arg(criterion) fn <- function(span) { mod <- update(model, span=span) as.crit(mod)[[criterion]] } result <- optimize(fn, span.range) return(list(span=result$minimum, criterion=result$objective)) } subdata <- subset(data, group==g) if (dim=="one") { if (is.null(user.span)) { loc0 <- loess(y ~ x, degree=degree,family = family, data=subdata) span1 <- opt.span.sub(loc0, criterion=criterion)$span } else { span1 <- user.span } loc1 <- loess(y ~ x, degree=degree, span=span1, family = family, data=subdata,...) } else { if (is.null(user.span)) { loc0 <- loess(y ~ x1 + x2, degree=degree,family = family, data=subdata) span1 <- opt.span.sub(loc0, criterion=criterion)$span } else { span1 <- user.span } loc1 <- loess(y ~ x1 + x2, degree=degree, span=span1, family = family, data=subdata,...) } return(loc1) } ## Fit the curves or surfaces if (ncol(x)==1) { if (is.null(user.span)) { fit0 <- loess(y ~ x, degree=degree, family = family, data=data.bind, ...) span1 <- opt.span(fit0, criterion=criterion)$span fit <- loess(y ~ x, degree=degree, span=span1, family = family, data=data.bind, ...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="one", degree=degree, criterion=criterion, family = family, ...) } else { span1 <- user.span fit <- loess(y ~ x, degree=degree, span=span1, family = family, data=data.bind, ...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="one", degree=degree, criterion=criterion, family = family, user.span=span1, ...) } } else { if (is.null(user.span)) { fit0 <- loess(y ~ x1 + x2, degree=degree,family = family, data.bind, ...) span1 <- opt.span(fit0, criterion=criterion)$span fit <- loess(y ~ x1 + x2, degree=degree, span=span1, family = family, data=data.bind,...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="two", degree=degree, criterion=criterion, family = family, ...) } else { span1 <- user.span fit <- loess(y ~ x1 + x2, degree=degree, span=span1, family = family, data=data.bind,...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="two", degree=degree, criterion=criterion, family = family, user.span=span1, ...) } } ## Wild Bootstrap y.boot <- matrix(rep(fit$fitted,B),fit$n) + wild.boot(fit$res, nboot=B) if (ncol(x)==1) { x.boot <- matrix(rep(fit$x,B),fit$n) } else {x.boot <- matrix(rep(fit$x,B), 2*fit$n)} group.boot <- matrix(rep(data.bind$group,B),fit$n) data.bind.boot <- rbind(x.boot, y.boot, group.boot) ## pairwise difference pwdiff <- function(i, mat) { z <- mat[, i-1] - mat[, i:ncol(mat), drop = FALSE] colnames(z) <- paste(colnames(mat)[i-1], colnames(z), sep = "-") z } ## Compute test statistics # find the range to calcaulate the integration if (ncol(x) == 1){ u.min <- max(unlist(lapply(fit.sub, function(x) min(x$x)))) u.max <- min(unlist(lapply(fit.sub, function(x) max(x$x)))) u <- runif(m, min=u.min, max=u.max) fit.sub.u <- matrix(unlist(lapply(fit.sub, function(x) predict(x, data.frame(x = u)))),nrow=m) fit.sub.u.diff <- do.call("cbind", sapply(2:ncol(fit.sub.u), pwdiff, fit.sub.u)) T.L2 <- sum(apply(fit.sub.u.diff^2, 2, mean)) } else { u1.min <- max(unlist(lapply(fit.sub, function(x) min(x$x[,1])))) u1.max <- min(unlist(lapply(fit.sub, function(x) max(x$x[,1])))) u1 <- runif(m, min=u1.min, max=u1.max) u2.min <- max(unlist(lapply(fit.sub, function(x) min(x$x[,2])))) u2.max <- min(unlist(lapply(fit.sub, function(x) max(x$x[,2])))) u2 <- runif(m, min=u2.min, max=u2.max) fit.sub.u <- matrix(unlist(lapply(fit.sub, function(x) predict(x, data.frame(x1 = u1, x2 = u2)))),nrow=m) fit.sub.u.diff <- do.call("cbind", sapply(2:ncol(fit.sub.u), pwdiff, fit.sub.u)) T.L2 <- sum(apply(fit.sub.u.diff^2, 2, mean)) } span0 <- fit$pars$span span.sub <- unlist(lapply(fit.sub, function(x) x$pars$span)) g.span0 <- cbind(g,span.sub) T.L2.boot1 <- function(data, span, g.span, u, nvar=3, degree=1, family = c("gaussian", "symmetric")){ data1 <- matrix(data, ncol=nvar) data1 <- data.frame(data1) colnames(data1)=c('x','y','group') loc.fit.sub0 <- function(g.span, data, degree=degree, family = family, ...){ loc1 <- loess(y ~ x, degree=degree, span=g.span[2], subset=(group==g.span[1]), family = family, data=data, ...) return(loc1) } fit.sub <- apply(g.span, 1, loc.fit.sub0, data=data1, degree=degree, family=family, ...) fit.sub.u <- matrix(unlist(lapply(fit.sub, function(x) predict(x, data.frame(x = u)))),nrow=length(u)) fit.sub.u.diff <- do.call("cbind", sapply(2:ncol(fit.sub.u), pwdiff, fit.sub.u)) T.L2 <- sum(apply(fit.sub.u.diff^2, 2, mean)) return(T.L2) } T.L2.boot2 <- function(data, span, g.span, u1, u2, nvar=4, degree=1, family = c("gaussian", "symmetric")){ data1 <- matrix(data, ncol=nvar) data1 <- data.frame(data1) colnames(data1)=c('x1', 'x2', 'y','group') loc.fit.sub0 <- function(g.span, data, degree=degree, family = family, ...){ loc1 <- loess(y ~ x1 + x2, degree=degree, span=g.span[2], subset=(group==g.span[1]), family = family, data=data, ...) return(loc1) } fit.sub <- apply(g.span, 1, loc.fit.sub0, data=data1, degree=degree, family=family, ...) fit.sub.u <- matrix(unlist(lapply(fit.sub, function(x) predict(x, data.frame(x1 = u1, x2 = u2)))), nrow=length(u1)) fit.sub.u.diff <- do.call("cbind", sapply(2:ncol(fit.sub.u), pwdiff, fit.sub.u)) T.L2 <- sum(apply(fit.sub.u.diff^2, 2, mean)) return(T.L2) } if (ncol(x)==1) { T.L2.boot <- apply(data.bind.boot, 2, T.L2.boot1, span=span0, g.span=g.span0, u=u, degree=degree, family=family, ...) } else { T.L2.boot <- apply(data.bind.boot, 2, T.L2.boot2, span=span0, g.span=g.span0, u1=u1, u2=u2, degree=degree, family=family, ...)} pval <- (1+sum(T.L2.boot>T.L2))/(1+B) output <- list(statistic=T.L2, T.boot=T.L2.boot, p.value = pval, group=gn, fit=fit.sub, spans=span.sub, degree=degree, criterion=criterion, family = family, data=data.bind, method=method) class(output) <- "fANCOVA" return(output) } ## ------------------------------------------------------------------------- ## Test the equality of curves based on an ANOVA-type statistic #' @export T.aov <- function(x, ...) UseMethod("T.aov") #' @export T.aov.default <- function(x, y, group, B=200, degree=1, criterion=c("aicc", "gcv"), family = c("gaussian", "symmetric"), tstat= c("DN", "YB"), user.span=NULL, ...) { criterion <- match.arg(criterion) family <- match.arg(family) tstat <- match.arg(tstat) x <- as.matrix(x) if (ncol(x) == 1) { method <- "Test the equality of curves based on an ANOVA-type statistic" } else { if(ncol(x) == 2) { method <- "Test the equality of surfaces based on an ANOVA-type statistic" } else stop("The predictor 'x' should be one or two dimensional!!") } ## CheckValidity if (!is.numeric(x)) stop("argument 'x' must be numeric!") if (!is.numeric(y)) stop("argument 'y' must be numeric!") if (any(is.na(x))) stop("'x' contains missing values!") if (any(is.na(y))) stop("'y' contains missing values!") if (any(is.na(group))) stop("'group' contains missing values!") if (!is.null(user.span) && (length(user.span) != 1 || !is.numeric(user.span))) stop("argument 'user.span' must be a numerical number!") if(nrow(x) != length(y) | nrow(x) != length(group)) stop("'x', 'y' and 'group' have different lengths!") g <- unique(group) gn <- length(g) ny <- length(y) if(gn > ny/3) stop("check if there is error in the 'group' variable!") if(ny < 3*gn) stop("not enough observations!") data.bind <- data.frame(x=x, y=y, group=group) if (ncol(x) == 1) { names(data.bind) <- c("x", "y", "group") } else { names(data.bind) <- c("x1", "x2", "y", "group") } opt.span <- function(model, criterion=c("aicc", "gcv"), span.range=c(.05, .95)){ as.crit <- function (x) { span <- x$pars$span traceL <- x$trace.hat sigma2 <- sum(x$residuals^2 ) / (x$n-1) aicc <- log(sigma2) + 1 + 2* (2*(traceL+1)) / (x$n-traceL-2) gcv <- x$n*sigma2 / (x$n-traceL)^2 result <- list(span=span, aicc=aicc, gcv=gcv) return(result) } criterion <- match.arg(criterion) fn <- function(span) { mod <- update(model, span=span) as.crit(mod)[[criterion]] } result <- optimize(fn, span.range) return(list(span=result$minimum, criterion=result$objective)) } loc.fit.sub <- function(g, data, dim=c("one", "two"), degree=1, criterion=c("aicc", "gcv"), family = c("gaussian", "symmetric"), user.span=NULL, ...){ dim <- match.arg(dim) opt.span.sub <- function(model, criterion=c("aicc", "gcv"), span.range=c(.05, .95)){ as.crit <- function (x) { span <- x$pars$span traceL <- x$trace.hat sigma2 <- sum(x$residuals^2 ) / (x$n-1) aicc <- log(sigma2) + 1 + 2* (2*(traceL+1)) / (x$n-traceL-2) gcv <- x$n*sigma2 / (x$n-traceL)^2 result <- list(span=span, aicc=aicc, gcv=gcv) return(result) } criterion <- match.arg(criterion) fn <- function(span) { mod <- update(model, span=span) as.crit(mod)[[criterion]] } result <- optimize(fn, span.range) return(list(span=result$minimum, criterion=result$objective)) } subdata <- subset(data, group==g) if (dim=="one") { if (is.null(user.span)) { loc0 <- loess(y ~ x, degree=degree,family = family, data=subdata) span1 <- opt.span.sub(loc0, criterion=criterion)$span } else { span1 <- user.span } loc1 <- loess(y ~ x, degree=degree, span=span1, family = family, data=subdata,...) } else { if (is.null(user.span)) { loc0 <- loess(y ~ x1 + x2, degree=degree,family = family, data=subdata) span1 <- opt.span.sub(loc0, criterion=criterion)$span } else { span1 <- user.span } loc1 <- loess(y ~ x1 + x2, degree=degree, span=span1, family = family, data=subdata,...) } return(loc1) } ## Fit the curves or surfaces if (ncol(x)==1) { if (is.null(user.span)) { fit0 <- loess(y ~ x, degree=degree, family = family, data=data.bind, ...) span1 <- opt.span(fit0, criterion=criterion)$span fit <- loess(y ~ x, degree=degree, span=span1, family = family, data=data.bind, ...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="one", degree=degree, criterion=criterion, family = family, ...) } else { span1 <- user.span fit <- loess(y ~ x, degree=degree, span=span1, family = family, data=data.bind, ...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="one", degree=degree, criterion=criterion, family = family, user.span=span1, ...) } } else { if (is.null(user.span)) { fit0 <- loess(y ~ x1 + x2, degree=degree,family = family, data.bind, ...) span1 <- opt.span(fit0, criterion=criterion)$span fit <- loess(y ~ x1 + x2, degree=degree, span=span1, family = family, data=data.bind,...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="two", degree=degree, criterion=criterion, family = family, ...) } else { span1 <- user.span fit <- loess(y ~ x1 + x2, degree=degree, span=span1, family = family, data=data.bind,...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="two", degree=degree, criterion=criterion, family = family, user.span=span1, ...) } } ## Wild Bootstrap y.boot <- matrix(rep(fit$fitted,B),fit$n) + wild.boot(fit$res, nboot=B) if (ncol(x)==1) { x.boot <- matrix(rep(fit$x,B),fit$n) } else {x.boot <- matrix(rep(fit$x,B), 2*fit$n)} group.boot <- matrix(rep(data.bind$group,B),fit$n) data.bind.boot <- rbind(x.boot, y.boot, group.boot) ## Compute test statistics if (tstat=="DN"){ T.aov <- mean((fit$fitted - unlist(lapply(fit.sub, function(x) {x$fitted})))^2) }else{ sigma2 <- sum(unlist(lapply(fit.sub, function(x) {sum((diff(x$y, lag=1))^2)})))/(2*(fit$n-gn)) T.aov <- sum((fit$fitted - unlist(lapply(fit.sub, function(x) {x$fitted})))^2)/sigma2 } span0 <- fit$pars$span span.sub <- unlist(lapply(fit.sub, function(x) x$pars$span)) g.span0 <- cbind(g,span.sub) T.aov.boot1 <- function(data, span, g.span, nvar=3, degree=1, family = c("gaussian", "symmetric"), tstat =c("DN", "YB"), ...){ data1 <- matrix(data, ncol=nvar) data1 <- data.frame(data1) colnames(data1)=c('x','y','group') fit <- loess(y ~ x, degree=degree, span=span, family = family, data=data1, ...) loc.fit.sub0 <- function(g.span, data, degree=degree, family = family, ...){ loc1 <- loess(y ~ x, degree=degree, span=g.span[2], subset=(group==g.span[1]), family = family, data=data, ...) return(loc1) } fit.sub <- apply(g.span, 1, loc.fit.sub0, data=data1, degree=degree, family=family, ...) tstat <- match.arg(tstat) if (tstat=="DN"){ T.aov <- mean((fit$fitted - unlist(lapply(fit.sub, function(x) {x$fitted})))^2) }else{ sigma2 <- sum(unlist(lapply(fit.sub, function(x) {sum((diff(x$y, lag=1))^2)})))/(2*(fit$n-gn)) T.aov <- sum((fit$fitted - unlist(lapply(fit.sub, function(x) {x$fitted})))^2)/sigma2 } return(T.aov) } T.aov.boot2 <- function(data, span, g.span, nvar=4, degree=1, family = c("gaussian", "symmetric"), tstat =c("DN", "YB"), ...){ data1 <- matrix(data, ncol=nvar) data1 <- data.frame(data1) colnames(data1)=c('x1', 'x2', 'y','group') fit <- loess(y ~ x1 + x2, degree=degree, span=span, family = family, data=data1, ...) loc.fit.sub0 <- function(g.span, data, degree=degree, family = family, ...){ loc1 <- loess(y ~ x1 + x2, degree=degree, span=g.span[2], subset=(group==g.span[1]), family = family, data=data, ...) return(loc1) } fit.sub <- apply(g.span, 1, loc.fit.sub0, data=data1, degree=degree, family=family, ...) tstat <- match.arg(tstat) if (tstat=="DN"){ T.aov <- mean((fit$fitted - unlist(lapply(fit.sub, function(x) {x$fitted})))^2) }else{ sigma2 <- sum(unlist(lapply(fit.sub, function(x) {sum((diff(x$y, lag=1))^2)})))/(2*(fit$n-gn)) T.aov <- sum((fit$fitted - unlist(lapply(fit.sub, function(x) {x$fitted})))^2)/sigma2 } return(T.aov) } if (ncol(x)==1) { T.aov.boot <- apply(data.bind.boot, 2, T.aov.boot1, span=span0, g.span=g.span0 , degree=degree, family=family, tstat=tstat, ...) } else { T.aov.boot <- apply(data.bind.boot, 2, T.aov.boot2, span=span0, g.span=g.span0, degree=degree, family=family, tstat=tstat, ...)} pval <- (1+sum(T.aov.boot>T.aov))/(1+B) output <- list(statistic=T.aov, T.boot=T.aov.boot, p.value = pval, group=gn, fit=fit.sub, spans=span.sub, degree=degree, criterion=criterion, family = family, data=data.bind, method=method) class(output) <- "fANCOVA" return(output) } ##------------------------------------------------------------- ## Test the equality of curves based on variance estimators #' @export T.var <- function(x, ...) UseMethod("T.var") #' @export T.var.default <- function(x, y, group, B=200, degree=1, criterion=c("aicc", "gcv"), family = c("gaussian", "symmetric"), user.span=NULL, ...) { criterion <- match.arg(criterion) family <- match.arg(family) x <- as.matrix(x) if (ncol(x) == 1) { method <- "Test the equality of curves based on variance estimators" } else { if(ncol(x) == 2) { method <- "Test the equality of surfaces based on variance estimators" } else stop("The predictor 'x' should be one or two dimensional!!") } ## CheckValidity if (!is.numeric(x)) stop("argument 'x' must be numeric!") if (!is.numeric(y)) stop("argument 'y' must be numeric!") if (any(is.na(x))) stop("'x' contains missing values!") if (any(is.na(y))) stop("'y' contains missing values!") if (any(is.na(group))) stop("'group' contains missing values!") if (!is.null(user.span) && (length(user.span) != 1 || !is.numeric(user.span))) stop("argument 'user.span' must be a numerical number!") if(nrow(x) != length(y) | nrow(x) != length(group)) stop("'x', 'y' and 'group' have different lengths!") g <- unique(group) gn <- length(g) ny <- length(y) if(gn > ny/3) stop("check if there is error in the 'group' variable!") if(ny < 3*gn) stop("not enough observations!") data.bind <- data.frame(x=x, y=y, group=group) if (ncol(x) == 1) { names(data.bind) <- c("x", "y", "group") } else { names(data.bind) <- c("x1", "x2", "y", "group") } opt.span <- function(model, criterion=c("aicc", "gcv"), span.range=c(.05, .95)){ as.crit <- function (x) { span <- x$pars$span traceL <- x$trace.hat sigma2 <- sum(x$residuals^2 ) / (x$n-1) aicc <- log(sigma2) + 1 + 2* (2*(traceL+1)) / (x$n-traceL-2) gcv <- x$n*sigma2 / (x$n-traceL)^2 result <- list(span=span, aicc=aicc, gcv=gcv) return(result) } criterion <- match.arg(criterion) fn <- function(span) { mod <- update(model, span=span) as.crit(mod)[[criterion]] } result <- optimize(fn, span.range) return(list(span=result$minimum, criterion=result$objective)) } loc.fit.sub <- function(g, data, dim=c("one", "two"), degree=1, criterion=c("aicc", "gcv"), family = c("gaussian", "symmetric"), user.span=NULL, ...){ dim <- match.arg(dim) opt.span.sub <- function(model, criterion=c("aicc", "gcv"), span.range=c(.05, .95)){ as.crit <- function (x) { span <- x$pars$span traceL <- x$trace.hat sigma2 <- sum(x$residuals^2 ) / (x$n-1) aicc <- log(sigma2) + 1 + 2* (2*(traceL+1)) / (x$n-traceL-2) gcv <- x$n*sigma2 / (x$n-traceL)^2 result <- list(span=span, aicc=aicc, gcv=gcv) return(result) } criterion <- match.arg(criterion) fn <- function(span) { mod <- update(model, span=span) as.crit(mod)[[criterion]] } result <- optimize(fn, span.range) return(list(span=result$minimum, criterion=result$objective)) } subdata <- subset(data, group==g) if (dim=="one") { if (is.null(user.span)) { loc0 <- loess(y ~ x, degree=degree,family = family, data=subdata) span1 <- opt.span.sub(loc0, criterion=criterion)$span } else { span1 <- user.span } loc1 <- loess(y ~ x, degree=degree, span=span1, family = family, data=subdata,...) } else { if (is.null(user.span)) { loc0 <- loess(y ~ x1 + x2, degree=degree,family = family, data=subdata) span1 <- opt.span.sub(loc0, criterion=criterion)$span } else { span1 <- user.span } loc1 <- loess(y ~ x1 + x2, degree=degree, span=span1, family = family, data=subdata,...) } return(loc1) } ## Fit the curves or surfaces if (ncol(x)==1) { if (is.null(user.span)) { fit0 <- loess(y ~ x, degree=degree, family = family, data=data.bind, ...) span1 <- opt.span(fit0, criterion=criterion)$span fit <- loess(y ~ x, degree=degree, span=span1, family = family, data=data.bind, ...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="one", degree=degree, criterion=criterion, family = family, ...) } else { span1 <- user.span fit <- loess(y ~ x, degree=degree, span=span1, family = family, data=data.bind, ...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="one", degree=degree, criterion=criterion, family = family, user.span=span1, ...) } } else { if (is.null(user.span)) { fit0 <- loess(y ~ x1 + x2, degree=degree,family = family, data.bind, ...) span1 <- opt.span(fit0, criterion=criterion)$span fit <- loess(y ~ x1 + x2, degree=degree, span=span1, family = family, data=data.bind,...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="two", degree=degree, criterion=criterion, family = family, ...) } else { span1 <- user.span fit <- loess(y ~ x1 + x2, degree=degree, span=span1, family = family, data=data.bind,...) fit.sub <- lapply(g, loc.fit.sub, data=data.bind, dim="two", degree=degree, criterion=criterion, family = family, user.span=span1, ...) } } ## Wild Bootstrap y.boot <- matrix(rep(fit$fitted,B),fit$n) + wild.boot(fit$res, nboot=B) if (ncol(x)==1) { x.boot <- matrix(rep(fit$x,B),fit$n) } else {x.boot <- matrix(rep(fit$x,B), 2*fit$n)} group.boot <- matrix(rep(data.bind$group,B),fit$n) data.bind.boot <- rbind(x.boot, y.boot, group.boot) ## Compute test statistics T.var <- sum(fit$res^2)/fit$n - sum(unlist(lapply(fit.sub, function(x) {sum(x$res^2)})))/fit$n span0 <- fit$pars$span span.sub <- unlist(lapply(fit.sub, function(x) x$pars$span)) g.span0 <- cbind(g,span.sub) T.var.boot1 <- function(data, span, g.span, nvar=3, degree=1, family = c("gaussian", "symmetric"), ...){ data1 <- matrix(data, ncol=nvar) data1 <- data.frame(data1) colnames(data1)=c('x','y','group') fit <- loess(y ~ x, degree=degree, span=span, family = family, data=data1, ...) loc.fit.sub0 <- function(g.span, data, degree=degree, family = family, ...){ loc1 <- loess(y ~ x, degree=degree, span=g.span[2], subset=(group==g.span[1]), family = family, data=data, ...) return(loc1) } fit.sub <- apply(g.span, 1, loc.fit.sub0, data=data1, degree=degree, family=family, ...) T.var <- sum(fit$res^2)/fit$n - sum(unlist(lapply(fit.sub, function(x) {sum(x$res^2)})))/fit$n return(T.var) } T.var.boot2 <- function(data, span, g.span, nvar=4, degree=1, family = c("gaussian", "symmetric"), ...){ data1 <- matrix(data, ncol=nvar) data1 <- data.frame(data1) colnames(data1)=c('x1', 'x2', 'y','group') fit <- loess(y ~ x1 + x2, degree=degree, span=span, family = family, data=data1, ...) loc.fit.sub0 <- function(g.span, data, degree=degree, family = family, ...){ loc1 <- loess(y ~ x1 + x2, degree=degree, span=g.span[2], subset=(group==g.span[1]), family = family, data=data, ...) return(loc1) } fit.sub <- apply(g.span, 1, loc.fit.sub0, data=data1, degree=degree, family=family, ...) T.var <- sum(fit$res^2)/fit$n - sum(unlist(lapply(fit.sub, function(x) {sum(x$res^2)})))/fit$n return(T.var) } if (ncol(x)==1) { T.var.boot <- apply(data.bind.boot, 2, T.var.boot1, span=span0, g.span=g.span0 , degree=degree, family=family, ...) } else { T.var.boot <- apply(data.bind.boot, 2, T.var.boot2, span=span0, g.span=g.span0, degree=degree, family=family, ...)} pval <- (1+sum(T.var.boot>T.var))/(1+B) output <- list(statistic=T.var, T.boot=T.var.boot, p.value = pval, group=gn, criterion=criterion, fit.summary=fit.sub, spans=span.sub, data=data.bind, method=method) output <- list(statistic=T.var, T.boot=T.var.boot, p.value = pval, group=gn, fit=fit.sub, spans=span.sub, degree=degree, criterion=criterion, family = family, data=data.bind, method=method) class(output) <- "fANCOVA" return(output) } #' @export print.fANCOVA <- function (x, digits = 4, ...){ if (ncol(x$data) == 3) {curve.surface <- "curves"; curve.surface2 <- "curve"} else {curve.surface <- "surfaces"; curve.surface2 <- "surface"} cat("\n") cat(strwrap(x$method, prefix = "\t"), sep="\n") cat("\n") cat("Comparing", x$group, "nonparametric regression", curve.surface, "\n") cat("Local polynomial regression with automatic smoothing parameter selection via", toupper(x$criterion), "is used for", curve.surface2, "fitting.", "\n") cat("Wide-bootstrap algorithm is applied to obtain the null distribution.", "\n") cat("\n") cat("Null hypothesis: there is no difference between the ", x$group, " ", curve.surface, sep="", ".\n") cat("T = ", formatC(x$statistic, digits = digits), " ", "p-value = ", formatC(x$p.value, digits = digits), "\n") cat("\n") invisible(x) } #' @export plot.fANCOVA <- function(x, test.statistic=TRUE, main="", n=256, legend.position="topright", ...) { if (test.statistic) { plot(density(x$T.boot, ...), type = "l", lwd=1.5, main=main, xlab="Test Statistic", ylab="Density",...) text <- paste(" T = ", formatC(x$statistic, digits = 4),"\n","p-value = ", formatC(x$p.value, digits = 4)) legend(x = legend.position, legend = text) } else { if (ncol(x$data)==3) { fit.sub <- x$fit u.min <- max(unlist(lapply(fit.sub, function(x) min(x$x)))) u.max <- min(unlist(lapply(fit.sub, function(x) max(x$x)))) u <- seq(from=u.min, to=u.max, length.out=n) fit.sub.u <- matrix(unlist(lapply(fit.sub, function(x) predict(x, data.frame(x=u)))), nrow=n) matplot(u, fit.sub.u, lty=1:x$group, col=1:x$group, type="l", lwd=1.5, xlab="x", ylab="m(x)") text <- paste("group", 1:x$group, sep="") legend(x = legend.position, legend = text, lty=1:x$group, col=1:x$group, lwd=1.5) } else { text <- "The fitted surfaces are displayed by groups using the function!" text } } } fANCOVA/MD50000644000176200001440000000123313753533342011706 0ustar liggesusersad13278cd3b9cdaa74152e41f929bf96 *DESCRIPTION 805373ee1363745659f5fd28f2e69638 *NAMESPACE ae127f8885871ca988816d4be2f27d64 *NEWS 8b7c6790d727b0bccee6a6c5e167e691 *R/fANOVA_all.R b85a08a5372f955264ee082c55d3217e *R/zzz.R c265fade7f42e905f21c383811800c62 *data/USpopu.tab b3ec72e17462309c96a32154144acab0 *man/T.L2.Rd c80c9eae0b68b4c068938440d239f700 *man/T.aov.Rd d4a0a54923b0b4bbf105c412adc8b722 *man/T.var.Rd ff4e9b68bdf9f548dad69a7ed75a1f47 *man/USpopu.Rd 9b9348813be4903575213c90a1acc272 *man/loess.ancova.Rd 0a95d440b2956c1f3aa05e88e1cee92c *man/loess.as.Rd 2369b6816dd125f2833e5a2b3d6f2294 *man/plot.fANCOVA.Rd 8dc78eea9bba4d9a7e489f39947375f1 *man/wild.boot.Rd