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
gg.R
gg <- function(x,r=1,method=NULL,usedeldir=TRUE,open=TRUE,k=NA,algorithm='cover_tree')
{
	n <- nrow(x)
	if(is.na(k)){
		dx <- as.matrix(proxy::dist(x,method=method))
		A <- matrix(0,nrow=n,ncol=n)
		if(is.vector(x)) x <- matrix(x,ncol=1)
		if(usedeldir && (method=="Euclidean" || is.null(method)) && (ncol(x)==2)){
		  del <- deldir(x[,1],x[,2])
		  for(edge in 1:nrow(del$delsgs)){
			 i <- del$delsgs[edge,5]
			 j <- del$delsgs[edge,6]
			 d1 <- r*dx[i,j]/2
			 d <- proxy::dist((x[i,,drop=FALSE]+x[j,,drop=FALSE])/2,x,
			          method=method)
			 d[i] <- Inf
			 d[j] <- Inf
			 if(open){
				 if(!any(d<d1)){
					 A[i,j] <- 1
					 A[j,i] <- 1
				 }
			 } else {
				 if(!any(d<=d1)){
					 A[i,j] <- 1
					 A[j,i] <- 1
				 }
			 }
		  }
		} else {
			for(i in 1:n){
			  for(j in setdiff(1:n,i)){
				 d1 <- r*dx[i,j]/2
				 d1 <- round(d1,10)
				 d <- proxy::dist((x[i,,drop=FALSE]+x[j,,drop=FALSE])/2,x,
				          method=method)
				 d <- round(d,10)
				 d[i] <- Inf
				 d[j] <- Inf
				 if(open){
					 if(!any(d<d1)){
						 A[i,j] <- 1
						 A[j,i] <- 1
					 }
				 } else {
					 if(!any(d<=d1)){
						 A[i,j] <- 1
						 A[j,i] <- 1
					 }
				 }
			 }
		  } 
   } 
	diag(A) <- 0
	g <- graph_from_adjacency_matrix(A,mode="undirected")
  } else {
	  k <- min(k,n-1)
	  dx <- get.knn(x,k=k,algorithm=algorithm)
	  edges <- NULL
	  for(i in 1:n){
		  i.indices <- dx$nn.index[i,]
		  i.dists <- dx$nn.dist[i,]
		  for(j in 1:k){
			  rd <- r*i.dists[j]/2
			  j.indices <- dx$nn.index[i.indices[j],]
			  S <- setdiff(intersect(i.indices,j.indices),c(i,i.indices[j]))
			  if(length(S)>0){
				  X <- (x[i,,drop=FALSE]+x[i.indices[j],,drop=FALSE])/2
				  Y <- x[S,,drop=FALSE]
				  d <- min(as.vector(proxy::dist(X,Y)))
				  if(d>rd){
					  edges <- cbind(edges,c(i,i.indices[j]))
				  }
			  }
		  }
	  }
	  g <- simplify(make_graph(edges,n=n,directed=FALSE))
  }
	g$layout <- x
	g$r <- r
   g
}

back to top