I have troubles with my code that is supposed to determine whether a given natural number is highly composite or not. So far, I have come up with this:
ex33 <- function(x){
fact <- function(x) {
x <- as.integer(x)
div <- seq_len(abs(x))
factors <- div[x %% div == 0L]
return(factors)
}
k <- length(fact(x))
check <- NULL
tocheck <- c(1:(x-1))[-fact(x)]
for (i in tocheck) {
l <- length(fact(i))
if (l>=k){
check[i]<-1
break
}else{
check[i]<-0
}
}
if (1 %in% check){
return(FALSE)
}else{
return(TRUE)
}
}
I know, this is quite ineffective and slow, but I could not find another algorithm to speed this function up.
Related
I have to functions f, and g with known initial values for f(1), and g(1) and their subsequent values are obtained trough iteration according to: f(n+1)=f(n)\cos(g(n))-g(n)\sin(g(n)) and g(n+1)=f(n)\cos(g(n))+g(n)\sin(g(n)) . I have been trying to solve this in R using:
N=100
for(n in 1:N)
{
f=function(n)
g=function(n)
if(n == 1) {
f(1)=0.8
g(1)=0.6} else {
f(n)=f(n-1)cos(g(n-1))-g(n-1)sin(g(n-1)
g(n)=f(n-1)cos(g(n-1))+g(n-1)sin(g(n-1))
}
However, this is not working. Any suggestions?
I am not sure that the following answers the question. But here are some errors in the code:
The functions are defined in the for loop.
None of the two functions is ever called.
My best guess is
f <- function(n){
if(n == 1){
0.8
}else{
f(n-1)*cos(g(n-1))-g(n-1)*sin(g(n-1))
}
}
g <- function(n){
if(n == 1) {
0.6
} else {
f(n-1)*cos(g(n-1))+g(n-1)*sin(g(n-1))
}
}
N <- 10
y <- numeric(N)
for(n in 1:N) {
y[n] <- f(n)
cat(y[n], "\n")
}
y
I have this piece of code:
library("GO.db")
lookParents <- function(x) {
parents <- subset(yy[x][[1]], labels(yy[x][[1]])=="is_a")
for (parent in parents) {
m[index,1] <<- Term(x)
m[index,2] <<- Term(parent)
m[index,3] <<- -log2(go_freq[x,1]/go_freq_all)
m[index,4] <<- log2(go1_freq2[x])
m[index,5] <<- x
m[index,6] <<- parent
index <<- index + 1
}
if (is.null(parents)) {
return(c())
} else {
return(parents)
}
}
getTreeMap <- function(GOlist, xx, m) {
print(paste("Input list has",length(GOlist), "terms", sep=" "))
count <- 1
for (go in GOlist) {
parents <- lookParents(go)
if (count %% 100 == 0) {
print(count)
}
while (length(parents) != 0) {
x <- parents[1]
parents <- parents[-1]
parents <- c(lookParents(x), parents)
}
count <- count + 1
}
}
xx <- c(as.list(GOBPANCESTOR), as.list(GOCCANCESTOR), as.list(GOMFANCESTOR))
go1_freq2 <- table(as.character(unlist(xx[go1])))
xx <- c(as.list(GOBPPARENTS), as.list(GOCCPARENTS), as.list(GOMFPARENTS))
m <- as.data.frame(matrix(nrow=1,ncol=6))
m[1,] <- c("all", "null", 0, 0, "null","null")
##biological processes
index <- 2
getTreeMap(BP, xx, m)
but it is really slow. BP is simply a vector. Do you have performance suggestions to apply? I would like to make it run faster, but that's all I can do at the moment.
I suggest following improvements:
add your functions into RProfile.site and compile them using cmpfun
use foreach and dopar instead of normal for
always delete the variables you don't need anymore and then call the garbage collector
I am trying to recreate the Biclique Communities method (Lehmann, Schwartz, & Hansen, 2008) in R which relies on the definition of a Ka,b biclique. The example below shows two adjacent K2,2 bicliques - the first clique is {A,B,1,2} and the second clique is {B,C,2,3}. I would like to be able to identify these cliques using R so that I can apply this to a broader dataset.
I have included my attempt so far in R and I am stuck with the following two issues:
If I use the standard walktrap.community it recognises the communities but does not allow the set {B,2} to belong in both cliques
If I use an updated clique.community function this doesn't seem to identify the cliques or I don't understand correctly (or both)
Example code:
library(igraph)
clique.community <- function(graph, k) {
clq <- cliques(graph, min=k, max=k)
edges <- c()
for (i in seq_along(clq)) {
for (j in seq_along(clq)) {
if ( length(unique(c(clq[[i]], clq[[j]]))) == k+1 ) {
edges <- c(edges, c(i,j))
}
}
}
clq.graph <- simplify(graph(edges))
V(clq.graph)$name <- seq_len(vcount(clq.graph))
comps <- decompose.graph(clq.graph)
lapply(comps, function(x) {
unique(unlist(clq[ V(x)$name ]))
})
}
users <- c('A', 'A', 'B', 'B', 'B', 'C', 'C')
resources <- c(1, 2, 1, 2, 3, 2, 3)
cluster <- data.frame(users, resources)
matrix <- as.data.frame.matrix(table(cluster))
igraph <- graph.incidence(matrix)
clique.community(igraph, 2)
walktrap.community(igraph)
Beware that the above solution becomes inefficient very quickly even for small (dense) graphs and values of k,l due to the fact that comb <- combn(vMode1, k) becomes extremely large.
A more efficient solution can be found in the "biclique" package that is in development at https://github.com/YupingLu/biclique.
I managed to find a script for this in the Sisob workbench
computeBicliques <- function(graph, k, l) {
vMode1 <- c()
if (!is.null(V(graph)$type)) {
vMode1 <- which(!V(graph)$type)
vMode1 <- intersect(vMode1, which(degree(graph) >= l))
}
nb <- get.adjlist(graph)
bicliques <- list()
if (length(vMode1) >= k) {
comb <- combn(vMode1, k)
i <- 1
sapply(1:ncol(comb), function(c) {
commonNeighbours <- c()
isFirst <- TRUE
sapply(comb[,c], function(n) {
if (isFirst) {
isFirst <<- FALSE
commonNeighbours <<- nb[[n]]
} else {
commonNeighbours <<- intersect(commonNeighbours, nb[[n]])
}
})
if (length(commonNeighbours) >= l) {
bicliques[[i]] <<- list(m1=comb[,c], m2=commonNeighbours)
}
i <<- i + 1
})
}
bicliques
}
I tried to implement a simple 2D single layer perceptron and ended up with this solution:
perceptron <- function(featureVec, classVec, wStart=matrix(c(0,0,0)), eta=1, limit = 50) {
plot(x=featureVec[,1],y=featureVec[,2])
# Extending dimensions
dimension <- dim(featureVec)[1]
featureVec <- cbind(featureVec,rep(1,dimension))
# Inverting 2. class
index <- classVec == -1
featureVec[index,] <- apply(matrix(featureVec[index]),1,prod,-1)
wTemp <- wStart
y <- featureVec %*% wTemp
iteration = 0
while (T) {
y <- featureVec %*% wTemp
delta <- as.matrix(featureVec[y <= 0,])
for(i in 1:nrow(delta)) {
wTemp <- wTemp + eta*delta[i,]
}
result <- featureVec %*% wTemp
if (sum(result <= 0) == 0) {
break
}
if (iteration >= limit) {
stop("Maximum count of interations reached!")
}
iteration = iteration + 1
}
if(wTemp[2] != 0) {
abline(-wTemp[3]/wTemp[2],-wTemp[1]/wTemp[2])
} else if(wTemp[2] == 0) {
abline(v=wTemp[1])
} else if(wTemp[1] == 0) {
abline(h=wTemp[2])
}
return(wTemp)
}
The feature vector works row-wise, the class vector needs values of 1 and -1 col-wise.
For most of my tests it works correct, but when I have samples like (0,0) (0,1) with classes (1,-1) I get no result. That happens with some of my examples with two points lying on a straight line (horizontal to a coordinate axis). When I try to choose different start vectors it sometimes works correctly (I have no deterministic behaviour here right now I guess). Is that a correct behaviour or is my implementation wrong?
Thanks for your help, Meiner.
EDIT: Some changes of the inital post.
Bad Dataset:
featureTest <- matrix(c(0,0,0,1),byrow=T,nrow=2)
classTest <- matrix(c(1,-1),nrow=2)
perceptron(featureTest,classTest)
featureTest <- matrix(c(0,1,0,2),byrow=T,nrow=2)
classTest <- matrix(c(1,-1),nrow=2)
perceptron(featureTest,classTest)
Good Dataset:
featureTest <- matrix(c(0,0,0,2),byrow=T,nrow=2)
classTest <- matrix(c(1,-1),nrow=2)
perceptron(featureTest,classTest)
I'm to get the vector simualted_results to take values returned by "simulation," which produced a vector of varying length depending on the iteration.
Initially I have this code which works, but is very slow:
simulated_results<-NULL
while(as.numeric(Sys.time())-start<duration){
simulated_results <- cbind(simulated_results,simulation(J,4* (length(J)^2),0.0007,duration,start))
}
But its very slow so I modified it:
start<-as.numeric(Sys.time())
duration<-10
simulated_results<-NULL
simulated_results <- cbind(simulated_results,
replicate(n=10000,expr=(while(as.numeric(Sys.time())-start<duration)
{simulation(J,4*(length(J)^2),0.0007,duration,start)})))
Now with the new code, my problem is that despite everything running, I cant get the results of simulation to be passed to simualted_results, instead simualted_results jsut takes on a column vector of NULL values
I get no error messages
I would greatly appreciate any help!!
for reference the simulation code is:
iter<-as.numeric(Sys.getenv("PBS_ARRAY_INDEX"))
if(iter <= 40){J<-1:500
}else if(iter <= 80){J<-1:1500
}else if(iter <= 120){J<-1:2500
}else if(iter <= 160){J<-1:5000}
set.seed(iter)
simulation <- function(J,gens,v=0.1,duration,start){
species_richness <- function(J){
a <- table(J)
return(NROW(a))
}
start<-as.numeric(Sys.time())
species_richness_output <- rep(NA,gens)
for(rep in 1:gens){
if (as.numeric(Sys.time())-start<duration){
index1 <- sample(1:length(J),1)
if(runif(1,0,1) < v){
J[index1] <- (rep+100)
}
else{
index2 <- sample(1:length(J),1)
while(index1==index2) {
index2 <- sample(1:length(J),1)
}
J[index1] <- J[index2]
}
species_richness_output[rep] <- species_richness(J)} else break
}
species_abundance <- function(J){
a <- table(J)
return(a)
}
abuntable <- species_abundance(J)
octaves <- function(abuntable)
{
oct<-rep(0,floor(log2(length(J))+1))
for(i in 1:length(abuntable)){
oct2 <- floor(log2(abuntable[i])+1)
oct[oct2] <- oct[oct2]+1
}
return(oct)
}
octaves(abuntable)
}
I agree with #Nathan G, but something did catch my attention: You are trying to cbind two things that cannot be bound together, since they have different dimensions. We don't know what kind of data type your simulation function returns, but it clearly is not NULL. Consider this:
df1 <- NULL
df2 <- data.frame(x = 1:10, y = 11:20)
cbind(df1, df2)
cbind(df2, df1)
Both cbind statements give errors. Do you get an error? If this is what's going on, you should initialize simulated_results not as NULL but as an empty version of whatever the function simulation returns.
EDIT
iter = 10
set.seed(iter)
J <- 1:1500
# critical to preallocate the list size for speed
res <- vector("list", iter)
for (i in 1: iter) {
res[[i]] <- simulation(J,4* (length(J)^2),0.0007,duration = 10,start)
}
str(res)
res[[1]]
Now I don't think I'm using this quite the way you ultimately intend, but perhaps this will give you enough to get to what you actually want.