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
rng.R
rng <- function(x=NULL,dx=NULL,r=1, method=NULL,usedeldir=TRUE,open=TRUE,k=NA,
                algorithm='cover_tree')
{
	if(is.na(k)){
		if(is.null(dx)) {
		  if(is.null(x)) stop("One of x or dx must be given.")
		  dx <- as.matrix(proxy::dist(x,method=method))
		} else {
			usedeldir <- FALSE
		}
		n <- nrow(dx)
		A <- matrix(0,nrow=n,ncol=n)
		if(is.vector(x)) x <- matrix(x,ncol=1)
		if(usedeldir && 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]
			 d <- min(apply(cbind(dx[i,-c(i,j)],dx[j,-c(i,j)]),1,max))
			 if(open){
				 if(r*dx[i,j] < d){
					 A[i,j] <- 1
					 A[j,i] <- 1
				 }
			 } else {
				 if(r*dx[i,j] <= d){
					 A[i,j] <- 1
					 A[j,i] <- 1
				 }
			 }
		  }
		}
		else{
		  diag(dx) <- Inf
		  for(i in 1:n){
			 for(j in setdiff(1:n,i)){
				 d <- min(apply(cbind(dx[i,-c(i,j)],dx[j,-c(i,j)]),1,max))
				 if(open){
					 if(r*dx[i,j] < d){
						 A[i,j] <- 1
						 A[j,i] <- 1
					 }
				 } else {
					 if(r*dx[i,j] <= d){
						 A[i,j] <- 1
						 A[j,i] <- 1
					 }
				 }
			 }
		  }
		}
		diag(A) <- 0
		out <- graph_from_adjacency_matrix(A,mode="undirected")
	} else {
	  if(is.null(x)) stop("x must not be null")
	  n <- nrow(x)
	  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],]
			  j.dists <- dx$nn.dist[i.indices[j],]
			  rd <- r*i.dists[j]
			  S <- setdiff(intersect(i.indices,j.indices),c(i,i.indices[j]))
			  if(length(S)>0){
				  d <- Inf
				  for(si in S){
					  a <- which(i.indices == si)
					  b <- which(j.indices == si)
					  d <- min(d,max(i.dists[a],j.dists[b]))
				  }
				  if(rd < d){
					  edges <- cbind(edges,c(i,i.indices[j]))
				  }
			  }
		  }
	  }
	  out <- simplify(make_graph(edges=edges,n=n,directed=FALSE))
	}
	if(!is.null(x)){
		out$layout <- x
	}
	out$r <- r
   out
}

back to top