https://github.com/cran/cccd
Raw File
Tip revision: de4ce40da7a3b119ee4d19055a910ee9a4ad2a63 authored by David J. Marchette on 08 April 2022, 11:22:29 UTC
version 1.6
Tip revision: de4ce40
ccd.R
ccd.nonsequential <- function(data,m=1,method=NULL)
{
   r <- rep(0,nrow(data))
   stats <- rep(0,nrow(data))
	walks <- matrix(0,ncol=nrow(data),nrow=nrow(data))
	fs <- matrix(0,ncol=nrow(data),nrow=nrow(data))
	rx <- matrix(0,ncol=nrow(data),nrow=nrow(data))
	for(i in 1:length(r)){
	   y <- data[i,,drop=FALSE]
	   d <- as.vector(proxy::dist(data,y,method=method))
	   od <- sort(d)
	   f <- (1:nrow(data))/nrow(data)
	   dif <- f-m*(od/max(od))^2
	   r[i] <- od[which.max(dif)]
	   stats[i] <- max(dif)
	   rx[i,] <- od
	   walks[i,] <- f
	   fs[i,] <- (od/max(od))^2
	}
   n <- nrow(data)
   A <- matrix(0,nrow=n,ncol=n)
   for(i in 1:n){
      A[i,] <- proxy::dist(data[i,,drop=FALSE],data,method=method)<r[i] 
   }
	diag(A) <- 0
	out <- graph_from_adjacency_matrix(A,mode="directed")
	out$R <- r
	out$stats <- stats
	out$layout <- data
	out$walks <- walks
	out$fs <- fs
	out$m <- m
	out$method <- method
	out
}

ccd.sequential <- function(data,m=1,alpha=0.05,method=NULL)
{
   n <- nrow(data)
   r <- rep(0,n)
   ks <- sqrt(qchisq(1-alpha,2)/(4*n))
   stats <- rep(0,n)
	walks <- matrix(0,ncol=n,nrow=n)
	fs <- matrix(0,ncol=n,nrow=n)
	rx <- matrix(0,ncol=n,nrow=n)
	for(i in 1:n){
	   y <- data[i,,drop=FALSE]
	   d <- as.vector(proxy::dist(data,y,method=method))
	   od <- sort(d)
	   f <- (1:nrow(data))/nrow(data)
	   dif <- f-m*(od/max(od))^2
      # find first one less than -ks
      a <- match(TRUE,c(0,dif)[1:n]< -ks,nomatch=n)
      r[i] <- od[which.max(dif[1:a])]
	   stats[i] <- max(dif[1:a])
	   rx[i,] <- od
	   walks[i,] <- f
	   fs[i,] <- (od/max(od))^2
	}
   A <- matrix(0,nrow=n,ncol=n)
   for(i in 1:n){
      A[i,] <- proxy::dist(data[i,,drop=FALSE],data,method=method)<r[i] 
   }
	diag(A) <- 0
	out <- graph_from_adjacency_matrix(A,mode="directed")
	out$R <- r
	out$stats <- stats
	out$layout <- data
	out$walks <- walks
	out$fs <- fs
	out$m <- m
	out$alpha <- alpha
	out$method <- method
	out
}

ccd <- function(data,m=1,alpha=0.05,sequential=TRUE,method=NULL)
{
   if(sequential)
	   z <- ccd.sequential(data,m,alpha,method=method)
   else
	   z <- ccd.nonsequential(data,m,method=method)
	class(z) <- c("ccd",class(z))
   z
}

plot.ccd <- function(x,...)
{
	g <- x
	class(g) <- c("cccd","igraph")
	plot(g,...)
}
back to top