I'm having a trouble reproducing the graph for the following code:
ThresholdingAlgo <- function(y,lag,threshold,influence) {
signals <- rep(0,length(y))
filteredY <- y[0:lag]
avgFilter <- NULL
stdFilter <- NULL
avgFilter[lag] <- mean(y[0:lag])
stdFilter[lag] <- sd(y[0:lag])
for (i in (lag+1):length(y)){
if (abs(y[i]-avgFilter[i-1]) > threshold*stdFilter[i-1]) {
if (y[i] > avgFilter[i-1]) {
signals[i] <- 1;
} else {
signals[i] <- -1;
}
filteredY[i] <- influence*y[i]+(1-influence)*filteredY[i-1]
} else {
signals[i] <- 0
filteredY[i] <- y[i]
}
avgFilter[i] <- mean(filteredY[(i-lag):i])
stdFilter[i] <- sd(filteredY[(i-lag):i])
}
return(list("signals"=signals,"avgFilter"=avgFilter,"stdFilter"=stdFilter))
}
y <- c(1,1,1.1,1,0.9,1,1,1.1,1,0.9,1,1.1,1,1,0.9,1,1,1.1,1,1,1,1,1.1,0.9,1,1.1,1,1,0.9,
1,1.1,1,1,1.1,1,0.8,0.9,1,1.2,0.9,1,1,1.1,1.2,1,1.5,1,3,2,5,3,2,1,1,1,0.9,1,1,3,
2.6,4,3,3.2,2,1,1,0.8,4,4,2,2.5,1,1,1)
# Run algo with lag = 30, threshold = 5, influence = 0
result <- ThresholdingAlgo(y,30,5,0)
# Plot result
par(mfrow = c(2,1),oma = c(2,2,0,0) + 0.1,mar = c(0,0,2,1) + 0.2)
plot(1:length(y),y,type="l",ylab="",xlab="")
lines(1:length(y),result$avgFilter,type="l",col="cyan",lwd=2)
lines(1:length(y),result$avgFilter+threshold*result$stdFilter,type="l",col="green",lwd=2)
lines(1:length(y),result$avgFilter-threshold*result$stdFilter,type="l",col="green",lwd=2)
plot(result$signals,type="S",col="red",ylab="",xlab="",ylim=c(-1.5,1.5),lwd=2)
The graph is suppose to look like this:
graph with two lines and shading
But when I run the code, I get "Error: object 'threshold' not found
My work around is using
threshold <- 5
But that gives me a slightly different graph. second graph, not prefered
Question: Why do I have to redefine the threshold in order to get the graph to work?
I pulled the code from this question on Stack. Peak signal detection in realtime timeseries data
Related
I was wondering about how to find the smallest circumcircle of an irregular polygon. I've worked with spatial polygons in R.
I want to reproduce some of the fragstats metrics in a vector mode because I had hard times with the package 'landscapemetrics' for a huge amount of data. In specific I would like to implement the circle (http://www.umass.edu/landeco/research/fragstats/documents/Metrics/Shape%20Metrics/Metrics/P11%20-%20CIRCLE.htm). So far, I could not find the formula or script for the smallest circumcircle.
All your comments are more than welcome.
Than you
As I mentioned in a comment, I don't know of existing R code for this, but a brute force search should be fast enough if you don't have too many points that need to be in the circle. I just wrote this one. The center() function is based on code from Wikipedia for drawing a circle around a triangle; circumcircle() is the function you want, found by brute force search through all circles that pass through 2 or 3 points in the set. On my laptop it takes about 4 seconds to handle 100 points. If you have somewhat bigger sets, you can probably get tolerable results by translating to C++, but it's an n^4 growth rate, so you'll need a better solution
for a really large set.
center <- function(D) {
if (NROW(D) == 0)
matrix(numeric(), ncol = 2)
else if (NROW(D) == 1)
D
else if (NROW(D) == 2) {
(D[1,] + D[2,])/2
} else if (NROW(D) == 3) {
B <- D[2,] - D[1,]
C <- D[3,] - D[1,]
Dprime <- 2*(B[1]*C[2] - B[2]*C[1])
if (Dprime == 0) {
drop <- which.max(c(sum((B-C)^2), sum(C^2), sum(B^2)))
center(D[-drop,])
} else
c((C[2]*sum(B^2) - B[2]*sum(C^2))/Dprime,
(B[1]*sum(C^2) - C[1]*sum(B^2))/Dprime) + D[1,]
} else
center(circumcircle(D))
}
radius <- function(D, U = center(D))
sqrt(sum((D[1,] - U)^2))
circumcircle <- function(P) {
n <- NROW(P)
if (n < 3)
return(P)
P <- P[sample(n),]
bestset <- NULL
bestrsq <- Inf
# Brute force search
for (i in 1:(n-1)) {
for (j in (i+1):n) {
D <- P[c(i,j),]
U <- center(D)
rsq <- sum((D[1,] - U)^2)
if (rsq >= bestrsq)
next
failed <- FALSE
for (k in (1:n)[-j][-i]) {
Pk <- P[k,,drop = FALSE]
if (sum((Pk - U)^2) > rsq) {
failed <- TRUE
break
}
}
if (!failed) {
bestset <- c(i,j)
bestrsq <- rsq
}
}
}
# Look for the best 3 point set
for (i in 1:(n-2)) {
for (j in (i+1):(n-1)) {
for (l in (j+1):n) {
D <- P[c(i,j,l),]
U <- center(D)
rsq <- sum((D[1,] - U)^2)
if (rsq >= bestrsq)
next
failed <- FALSE
for (k in (1:n)[-l][-j][-i]) {
Pk <- P[k,,drop = FALSE]
if (sum((Pk - U)^2) > rsq) {
failed <- TRUE
break
}
}
if (!failed) {
bestset <- c(i,j,l)
bestrsq <- rsq
}
}
}
}
P[bestset,]
}
showP <- function(P, ...) {
plot(P, asp = 1, type = "n", ...)
text(P, labels = seq_len(nrow(P)))
}
showD <- function(D) {
U <- center(D)
r <- radius(D, U)
theta <- seq(0, 2*pi, len = 100)
lines(U[1] + r*cos(theta), U[2] + r*sin(theta))
}
n <- 100
P <- cbind(rnorm(n), rnorm(n))
D <- circumcircle(P)
showP(P)
showD(D)
This shows the output
So I've created a while loop to give a coordinate point, Xm and Ym, which follows a uniform distribution, where the point must be within a circle of radius 25. Below is the code for that:
outcome<-function()
{
done=0
while(done==0){
Xm<-runif(1,-25,25)
Ym<-runif(1,-25,25)
if (Xm^2+Ym^2<=25^2){
z<-c(Xm,Ym)
done=1
}
}
z
}
outcome()
I now need to do the same thing, 250 times. I've changed the code to this:
plotoutcome<-function()
{
done=0
while(done==0){
Xm2<-runif(250,-25,25)
Ym2<-runif(250,-25,25)
if (Xm2^2+Ym2^2<=25^2){
z<-c(Xm2,Ym2)
done=1
}
}
z
}
plotoutcome()
However when I run the second code, I get this error message: In if (Xm2^2 + Ym2^2 <= 25^2) { :
the condition has length > 1 and only the first element will be used.
Any ideas on how to fix this?
The simplest way is to take advantage of outcome:
replicate(250, outcome())
But if a new function is needed, here is a plotoutcome function:
plotoutcome<-function()
{
total <- 0
done <- FALSE
Xtmp <- numeric(250)
Ytmp <- numeric(250)
while(!done){
Xm2 <- runif(1, -25, 25)
Ym2 <- runif(1, -25, 25)
i <- Xm2^2 + Ym2^2 <= 25^2
if(i){
total <- total + 1
Xtmp[total] <- Xm2
Ytmp[total] <- Ym2
}
done <- total == 250
}
list(X = Xtmp, Y = Ytmp)
}
do.call(cbind, plotoutcome())
Below piece of code is generating what I need but I am not able to store it so that I can use it further.
In the case below, I want to store each player's hand in a list of matrices p such that p[i]<-deck2[smpl,].
The second thing I want is to save and use the final matrix of deck2 (i.e say with 10 players, it will be a 29 row matrix). I can see NROW(deck2) as 29 but the assignment of d<-deck2 is not happening. What am I missing here?
deck2=matrix(c(rep( c(2:10,"J","Q","K","A"),4),rep(c("C","D","H","S"),rep(13,4))), ncol=2,dimnames=list(NULL,c("rank","suit")))
player_hands=function(players)
{ if(players >= 2 && players <= 10) {
for(i in 1:players)
{
smpl <- sample(1:NROW(deck2),2,replace=F)
r <- deck2[smpl,]
p <- deck2[smpl,]
deck2 <- deck2[-smpl,]
print(r)
if(i==players)
{ smpl <- sample(1:NROW(deck2),3,replace=F)
r <- deck2[smpl,]
p <- deck2[smpl,]
deck2 <- deck2[-smpl,]
print("Dealer Hand")
print(r)
}
else i=i+1
} }
else print("Invalid No. of Players")
}
I believe this should do what you want. It will return a list containing two items.
The first of these two items is the list of hands p, of which the last one will be the dealer's hand.
The second of the two items it returns will be the new deck2.
player_hands=function(players)
{ if(players >= 2 && players <= 10) {
p = list()
for(i in 1:players)
{
smpl <- sample(1:NROW(deck2),2,replace=F)
r <- deck2[smpl,]
p[[i]] = r
deck2 <- deck2[-smpl,]
if(i==players)
{ smpl <- sample(1:NROW(deck2),3,replace=F)
r <- deck2[smpl,]
p[[players+1]] <- r
deck2 <- deck2[-smpl,]
}
else i=i+1
}
return(list(p, deck2))
}
else print("Invalid No. of Players")
}
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 have a piece of code below. I am not able to understand how exactly "decompose.graph" works. In the below code, I want to see what is there in "comps". but it shows as some structure of lists, which I m not able to understand.
Also which function can I use to see the graphical representation of "comps"(I tried plot but it is not working)
gr<-graph(c(1,2,1,3,1,4,2,3,2,4,3,4),directed=FALSE)
cl<-cliques(gr,min=2,max=2)
edges <- c()
for (i in seq_along(cl)) {
for (j in seq_along(cl)) {
if ( length(unique(c(cl[[i]], cl[[j]]))) == 3 ) {
edges <- c(edges, c(i,j))
}
}
}
plot(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(cl[ V(x)$name ]))
})
Generally speaking if you want to see the code behind a function in R, you can type the function name at the command and press Enter. This will give you an overview of the code. For example:
> decompose
will give you:
function (x, type = c("additive", "multiplicative"), filter = NULL)
{
type <- match.arg(type)
l <- length(x)
f <- frequency(x)
if (f <= 1 || length(na.omit(x)) < 2 * f)
stop("time series has no or less than 2 periods")
if (is.null(filter))
filter <- if (!f%%2)
c(0.5, rep(1, f - 1), 0.5)/f
else rep(1, f)/f
trend <- filter(x, filter)
season <- if (type == "additive")
x - trend
else x/trend
periods <- l%/%f
index <- seq(1L, l, by = f) - 1
figure <- numeric(f)
for (i in 1L:f) figure[i] <- mean(season[index + i], na.rm = TRUE)
figure <- if (type == "additive")
figure - mean(figure)
else figure/mean(figure)
seasonal <- ts(rep(figure, periods + 1)[seq_len(l)], start = start(x),
frequency = f)
structure(list(x = x, seasonal = seasonal, trend = trend,
random = if (type == "additive") x - seasonal - trend else x/seasonal/trend,
figure = figure, type = type), class = "decomposed.ts")
}
<environment: namespace:forecast>
I tried the same for decompose.graph but I don't seem to have the function available. Is this isn a special library? I also have some challenges to execute your code as also the function cliques doesn't seem to be available; including what library you are working with would help.
Run the following code, you will know what's the function of decompose.graph()
library(igraph)
g <- sample_gnp(10, 1/10)
plot(g)
components <- decompose.graph(g, min.vertices=2)
par(mfrow = c(1, length(components)))
for (i in 1:length(components)){
plot(components[[i]])
}
First you will get a graph like this:
Graph created by sample_gnp()
After decompose.graph() you will get subgraphs like this:
Subgraph after decompose.graph()