Related
I am looking for the p-value at the frequency close to 90 days in my 365-day timeseries, but the Lomb package only calculates the highest power p-value:
ts = runif(365, 3, 18)
library(lomb)
lsp(ts,to=365,ofac=10,plot=FALSE,type='period')
The root code maybe help us. I have tried to change the values in pbaluev() function but when I modified it to the highest peak data, the output value is different from the p.value generated.
theme_lsp=function (bs=18){
theme_bw(base_size =bs,base_family="sans")+ theme(plot.margin = unit(c(.5,.5,.5,.5 ), "cm"))+
theme( axis.text.y =element_text (colour="black", angle=90, hjust=0.5,size=14),
axis.text.x = element_text(colour="black",size=14),
axis.title.y = element_text(margin = margin(t = 0, r = 15, b = 0, l = 0)),
axis.title.x = element_text(margin = margin(t = 15, r = 0, b = 0, l = 0)),
panel.grid.major = element_blank(), panel.grid.minor = element_blank())
}
lsp <- function (x, times = NULL, from = NULL, to = NULL, type = c("frequency", "period"), ofac = 1, alpha = 0.01, normalize=c("standard","press"), plot = TRUE, ...) {
type <- match.arg(type)
normalize<-match.arg(normalize)
if (ofac != floor(ofac)) {
ofac <- floor(ofac)
warning("ofac coerced to integer")
}
if (ofac < 1) {
ofac <- 1
warning("ofac must be integer >=1. Set to 1")
}
if (!is.null(times)) {
if (!is.vector(times))
stop("no multivariate methods available")
if (length(x) != length(times))
stop("Length of data and times vector must be equal")
names <- c(deparse(substitute(times)), deparse(substitute(x)))
}
if (is.null(times) && is.null(ncol(x))) {
names <- c("Time", deparse(substitute(x)))
times <- 1:length(x)
}
if (is.matrix(x) || is.data.frame(x)) {
if (ncol(x) > 2)
stop("no multivariate methods available")
if (ncol(x) == 2) {
names <- colnames(x)
times <- x[, 1]
x <- x[, 2]
}
}
times <- times[!is.na(x)]
x <- x[!is.na(x)]
nobs <- length(x)
if (nobs < 2)
stop("time series must have at least two observations")
times <- as.numeric(times)
start <- min(times)
end <- max(times)
av.int <- mean(diff(times))
o <- order(times)
times <- times[o]
x <- x[o]
y <- cbind(times, x)
colnames(y) <- names
datanames <- colnames(y)
t <- y[, 1]
y <- y[, 2]
n <- length(y)
tspan <- t[n] - t[1]
fr.d <- 1/tspan
step <- 1/(tspan * ofac)
if (type == "period") {
hold <- from
from <- to
to <- hold
if (!is.null(from))
from <- 1/from
if (!is.null(to))
to <- 1/to
}
if (is.null(to)) {
f.max <- floor(0.5 * n * ofac) * step
} else {
f.max <- to
}
freq <- seq(fr.d, f.max, by = step)
if (!is.null(from))
freq <- freq[freq >= from]
n.out <- length(freq)
if (n.out == 0)
stop("erroneous frequency range specified ")
x <- t * 2 * pi
y <- y - mean(y)
if (normalize=="standard") {
norm=1/sum(y^2)
} else if (normalize=="press"){
norm <- 1/(2 * var(y))
} else {
stop ("normalize must be 'standard' or 'press'")
}
w <- 2 * pi * freq
PN <- rep(0, n.out)
for (i in 1:n.out) {
wi <- w[i]
tau <- 0.5 * atan2(sum(sin(wi * t)), sum(cos(wi * t)))/wi
arg <- wi * (t - tau)
cs <- cos(arg)
sn <- sin(arg)
A <- (sum(y * cs))^2
B <- sum(cs * cs)
C <- (sum(y * sn))^2
D <- sum(sn * sn)
PN[i] <- A/B + C/D
}
PN <- norm * PN
PN.max <- max(PN)
peak.freq <- freq[PN == PN.max]
if (type == "period")
peak.at <- c(1/peak.freq, peak.freq) else peak.at <- c(peak.freq, 1/peak.freq)
scanned <- if (type == "frequency")
freq else 1/freq
if (type == "period") {
scanned <- scanned[n.out:1]
PN <- PN[n.out:1]
}
if (normalize=="press"){
effm <- 2 * n.out/ofac
level <- -log(1 - (1 - alpha)^(1/effm))
exPN <- exp(-PN.max)
p <- effm * exPN
if (p > 0.01) p <- 1 - (1 - exPN)^effm
}
if (normalize=="standard"){
fmax<-max(freq)
Z<-PN.max
tm=t
p<-pbaluev (Z,fmax,tm=t)
level=fibsearch(levopt,0,1,alpha,fmax=fmax,tm=t)$xmin
}
sp.out <- list(normalize=normalize, scanned = scanned, power = PN, data = datanames, n = n,
type = type, ofac = ofac, n.out = n.out, alpha = alpha,
sig.level = level, peak = PN.max, peak.at = peak.at, p.value = p, fmax = max(freq), Z = PN.max, tm = t,
PN = PN)
class(sp.out) <- "lsp"
if (plot) {
plot(sp.out, ...)
return(invisible(sp.out))
} else {
return(sp.out)}
}
plot.lsp <- function(x, main ="Lomb-Scargle Periodogram", xlabel = NULL, ylabel = "normalized power", level = TRUE, plot=TRUE, ...) {
if (is.null(xlabel))
xlabel <- x$type
scn=pow=NULL
dfp=data.frame(x$scanned,x$power)
names(dfp)=c("scn","pow")
p=ggplot(data=dfp,aes(x=scn,y=pow))+geom_line()
if (level == TRUE) {
if (!is.null(x$sig.level)) {
p=p+geom_hline(yintercept=x$sig.level, linetype="dashed",color="blue")
p=p+annotate("text",x=max(x$scanned)*0.85,y=x$sig.level*1.05,label=paste("P<",x$alpha),size=6,vjust=0)
}
}
p=p+ggtitle(main)
p=p+ ylab(ylabel)
p=p+ xlab(xlabel)
p=p+theme_lsp(20)
if (plot==T) print(p)
return (p)
}
summary.lsp <- function(object,...) {
first <- object$type
if (first == "frequency") {
second <- "At period"
} else {
second <- "At frequency"
}
first <- paste("At ", first)
from <- min(object$scanned)
to <- max(object$scanned)
Value <- c(object$data[[1]], object$data[[2]], object$n, object$type, object$ofac, from, to, object$n.out, object$peak, object$peak.at[[1]], object$peak.at[[2]], object$p.value,object$normalize)
options(warn = -1)
for (i in 1:length(Value)) {
if (!is.na(as.numeric(Value[i])))
Value[i] <- format(as.numeric(Value[i]), digits = 5)
}
options(warn = 0)
nmes <- c("Time", "Data", "n", "Type", "Oversampling", "From", "To", "# frequencies", "PNmax", first, second, "P-value (PNmax)", "normalized")
report <- data.frame(Value, row.names = nmes)
report
}
randlsp <- function(repeats=1000, x,times = NULL, from = NULL, to = NULL, type = c("frequency", "period"), ofac = 1, alpha = 0.01, plot = TRUE, trace = TRUE, ...) {
if (is.ts(x)){
x=as.vector(x)
}
if (!is.vector(x)) {
times <- x[, 1]
x <- x[, 2]
}
realres <- lsp(x, times, from, to, type, ofac, alpha,plot = plot, ...)
realpeak <- realres$peak
classic.p <-realres$p.value
pks <- NULL
if (trace == TRUE)
cat("Repeats: ")
for (i in 1:repeats) {
randx <- sample(x, length(x)) # scramble data sequence
randres <- lsp(randx, times, from, to, type, ofac, alpha, plot = F)
pks <- c(pks, randres$peak)
if (trace == TRUE) {
if (i/25 == floor(i/25))
cat(i, " ")
}
}
if (trace == TRUE)
cat("\n")
prop <- length(which(pks >= realpeak))
p.value <- prop/repeats
p.value=round(p.value,digits=3)
if (plot == TRUE) {
p1=plot(realres,main="LS Periodogram",level=F)
dfp=data.frame(pks)
names(dfp)="peaks"
p2=ggplot(data=dfp,aes(x=peaks))+geom_histogram(color="black",fill="white")
p2=p2+geom_vline(aes(xintercept=realpeak),color="blue", linetype="dotted", size=1)
p2=p2+theme_lsp(20)
p2=p2+ xlab("peak amplitude")
p2=p2+ggtitle(paste("P-value= ",p.value))
suppressMessages(grid.arrange(p1,p2,nrow=1))
}
res=realres[-(8:9)]
res=res[-length(res)]
res$random.peaks = pks
res$repeats=repeats
res$p.value=p.value
res$classic.p=classic.p
class(res)="randlsp"
return(invisible(res))
}
summary.randlsp <- function(object,...) {
first <- object$type
if (first == "frequency") {
second <- "At period"
} else {
second <- "At frequency"
}
first <- paste("At ", first)
from <- min(object$scanned)
to <- max(object$scanned)
Value <- c(object$data[[1]], object$data[[2]], object$n, object$type, object$ofac, from, to, length(object$scanned), object$peak, object$peak.at[[1]], object$peak.at[[2]], object$repeats,object$p.value)
options(warn = -1)
for (i in 1:length(Value)) {
if (!is.na(as.numeric(Value[i])))
Value[i] <- format(as.numeric(Value[i]), digits = 5)
}
options(warn = 0)
nmes <- c("Time", "Data", "n", "Type", "Oversampling", "From", "To", "# frequencies", "PNmax", first, second, "Repeats","P-value (PNmax)")
report <- data.frame(Value, row.names = nmes)
report
}
ggamma <- function(N){
return (sqrt(2 / N) * exp(lgamma(N / 2) - lgamma((N - 1) / 2)))
}
pbaluev <- function(Z,fmax,tm) {
#code copied from astropy timeseries
N=length(tm)
Dt=mean(tm^2)-mean(tm)^2
NH=N-1
NK=N-3
fsingle=(1 - Z) ^ (0.5 * NK)
Teff = sqrt(4 * pi * Dt) # Effective baseline
W = fmax * Teff
tau=ggamma(NH) * W * (1 - Z) ^ (0.5 * (NK - 1))*sqrt(0.5 * NH * Z)
p=-(exp(-tau)-1) + fsingle * exp(-tau)
return(p)
}
levopt<- function(x,alpha,fmax,tm){
prob=pbaluev(x,fmax,tm)
(log(prob)-log(alpha))^2
}
pershow=function(object){
datn=data.frame(period=object$scanned,power=object$power)
plot_ly(data=datn,type="scatter",mode="lines+markers",linetype="solid",
x=~period,y=~power)
}
getpeaks=function (object,npeaks=5,plotit=TRUE){
pks=findpeaks(object$power,npeaks=npeaks,minpeakheight=0,sortstr=TRUE)
peaks=pks[,1]
tmes=object$scanned[pks[,2]]
tme=round(tmes,2)
p=plot.lsp(object)
p=p+ylim(0,peaks[1]*1.2)
for (i in 1:npeaks){
p=p+annotate("text", label=paste(tme[i]),y=peaks[i],x=tme[i],color="red",angle=45,size=6,vjust=-1,hjust=-.1)
}
d=data.frame(time=tme,peaks=peaks)
result=list(data=d,plot=p)
return(result)
}
I want to implement RRHO analysis described in this manuscript https://academic.oup.com/nar/article/38/17/e169/1033168,
Maybe it's more clear and easy to see following R code to implement RRHO analysis. calculate_hyper_overlap function is what I try to do.
## Compute the overlaps between two *character* atomic vector:
hyper_test <- function(sample1, sample2, n) {
count <- length(intersect(sample1, sample2))
m <- length(sample1)
k <- length(sample2)
# under-enrichment
if (count <= m * k / n) {
sign <- -1L
pvalue <- stats::phyper(
q = count, m = m, n = n - m,
k = k, lower.tail = TRUE, log.p = FALSE
)
} else {
# over-enrichment
sign <- 1L
pvalue <- stats::phyper(
q = count, m = m, n = n - m,
k = k, lower.tail = FALSE, log.p = FALSE
)
}
c(count = count, pvalue = pvalue, sign = sign)
}
calculate_hyper_overlap <- function(sample1, sample2, n, stepsize) {
row_ids <- seq.int(stepsize, length(sample1), by = stepsize)
col_ids <- seq.int(stepsize, length(sample2), by = stepsize)
indexes <- expand.grid(
row_ids = row_ids,
col_ids = col_ids
)
overlaps <- apply(as.matrix(indexes), 1L, function(x) {
hyper_test(
sample1[seq_len(x[["row_ids"]])],
sample2[seq_len(x[["col_ids"]])],
n = n
)
}, simplify = FALSE)
overlaps <- data.table::transpose(overlaps)
number_of_obj <- length(row_ids)
matrix_counts <- matrix(
overlaps[[1L]],
nrow = number_of_obj
)
matrix_pvals <- matrix(
overlaps[[2L]],
nrow = number_of_obj
)
matrix_signs <- matrix(
overlaps[[3L]],
nrow = number_of_obj
)
list(
counts = matrix_counts,
pvalue = matrix_pvals,
signs = matrix_signs
)
}
The Rcpp code I use is here:
// [[Rcpp::export]]
List calculate_hyper_overlap_cpp(CharacterVector sample1, CharacterVector sample2, int n, int stepsize)
{
int list1_len = floor((sample1.size() - stepsize) / stepsize) + 1;
int list2_len = floor((sample2.size() - stepsize) / stepsize) + 1;
IntegerMatrix counts(list1_len, list2_len);
NumericMatrix pvalue(list1_len, list2_len);
IntegerMatrix signs(list1_len, list2_len);
for (int i = 0; i < list1_len; i++)
{
for (int j = 0; j < list2_len; j++)
{
CharacterVector list1 = sample1[Range(0, (i + 1) * stepsize - 1)];
CharacterVector list2 = sample2[Range(0, (j + 1) * stepsize - 1)];
int count = intersect(list1, list2).size();
counts(i, j) = count;
int m = list1.size(), k = list2.size();
if (count <= m * k / n)
// under-enrichment
{
pvalue(i, j) = R::phyper(count, m, n - m, k, true, false);
signs(i, j) = -1;
}
else
// over-enrichment
{
pvalue(i, j) = R::phyper(count, m, n - m, k, false, false);
signs(i, j) = 1;
}
}
}
return List::create(Named("counts") = counts,
Named("pvalue") = pvalue,
Named("signs") = signs);
}
here is the test:
n <- 200
sample1 <- rnorm(n)
sample2 <- rnorm(n)
names(sample1) <- names(sample2) <- paste0("gene", seq_len(n))
bench_res <- bench::mark(
res1 <- calculate_hyper_overlap_cpp(
names(sample1), names(sample2),
n = n, stepsize = 3L
),
res2 <- calculate_hyper_overlap(
names(sample1), names(sample2),
n = n, stepsize = 3L
),
check = FALSE
)
dplyr::select(bench_res, where(~ !is.list(.x)))
The test results
The first line is the time by Rcpp code and the second by raw R code
I am writing code for producing a variogram. For validating my result, I checked with geoR::variog() but both variograms are different.
I tried to understand the code of variog() to see what happens under the hood but there are so many things happening that I can't seem to understand it. I, in my code, am using the parameters X-coordinate, Y-coordiante, data value, number of lags, minimum lag value, lag interval, azimuth (angle in degrees; 90 corresponds to vertical direction), angle tolerance (in degrees) and maximum bandwidth.
variogram = function(xcor, ycor, data, nlag, minlag, laginv, azm, atol, maxbandw){
dl <- length(data)
lowangle <- azm - atol
upangle <- azm + atol
gamlag <- integer(nlag)
n <- integer(nlag)
dist <- pairdist(xcor, ycor)
maxd <- max(dist)
llag <- seq(minlag, minlag + (nlag-1) * laginv, by = laginv)
hlag <- llag + laginv
for(i in 1:dl){
for(j in i:dl){
if(i != j){
if(xcor[j]- xcor[i] == 0)
theta <- 90
else
theta <- 180/pi * atan((ycor[j] - ycor[i])/(xcor[j] - xcor[i]))
for(k in 1:nlag){
d <- dist[j, i]
b <- abs(d * sin(theta - azm))
if((llag[k] <= d & d < hlag[k]) & (lowangle <= theta & theta < upangle) & (b <= maxbandw)){
gamlag[k] <- gamlag[k] + (data[i] - data[j])^2;
n[k] <- n[k] + 1
}
}
}
}
}
gamlag <- ifelse(n == 0, NA, gamlag/(2*n))
tmp <- data.frame("lag" = llag, "gamma" = gamlag)
return(tmp)
}
function call for the above code
ideal_variogram_2 <- variogram(data3[,1], data3[,2], data3[,3], 18, 0, 0.025, 90, 45, 1000000)
ideal_variogram_2 <- na.omit(ideal_variogram_2)
plot(ideal_variogram_2$lag, ideal_variogram_2$gamma, main = "Using my code")
function call for variog()
geodata1 <- as.geodata(data3, coords.col = 1:2, data.col = 3)
ideal_variogram_1 <- variog(geodata1, coords = geodata1$coords, data = geodata1$data, option = "bin", uvec = seq(0, 0.45, by = 0.025), direction = pi/2, tolerance = pi/4)
df <- data.frame(u = ideal_variogram_1$u, v = ideal_variogram_1$v)
plot(df$u, df$v, main = "Using variog()")
The 2 variograms that I got are at the following link:
Variogram
I am currently doesn't some testing and analysis of the Micahelis-Menten enzyme kinetics model. And what my code is attempting to do is to change the rate parameter th1 to 50% up to 200% of it's max value.
What I want to do though is I want to produce 4 separate graphs which show what happens to MM1, MM2, MM3, MM4 when changing the rate parameter.
The issue that I have is regarding the "q" loop and where I use the "if", "else if" and "else" functions found near the end of my code.
MM <- list(Pre = matrix(c(1,0,0,1,0,0,0,1,1,0,0,0), ncol=4), Post =
matrix(c(0,1,0,0,1,1,1,0,0,0,0,1),ncol=4), M= c("x1"=301,"x2"=120, "x3"=0,
"x4"=0), h = function (x, t, th = c(1.66e-3, 1e-4 , 0.1))
{
with(as.list(c(x, th)), {
return(c(th[1] * x1 * x2, th[2] * x3, th[3] * x3))
})
})
gillespied1 <- function (N, T = 100, dt = 1, ...)
{
tt = 0
n = T%/%dt
x = N$M
S = t(N$Post - N$Pre)
u = nrow(S)
v = ncol(S)
xmat = matrix(ncol = u, nrow = n)
i = 1
target = 0
repeat {
h = N$h(x, tt, ...)
h0 = sum(h)
if (h0 < 1e-10)
tt = 1e+99
else if (h0>3000){
tt=1e+99
xmat[i] <- xmat[i-1] ###
i = i + 1
if(i > n)
return(ts(xmat, start = 0, deltat = dt)) ###
}
else tt = tt + rexp(1, h0)
while (tt >= target) {
xmat[i, ] = x
i = i + 1
target = target + dt
if (i > n)
return(ts(xmat, start = 0, deltat = dt))
}
j = sample(v, 1, prob = h)
x = x + S[, j]
}
}
cl = rainbow(13)
for(q in 1:4){
plot(1, type="n", xlab="Time", ylab="Concentration of Substrate",xaxt='n',
xlim=c(0, 1200), ylim=c(0, 310), main="Micahaelis-Menten:Changing Substrate rate parameter")
for(i in seq(from=50, to=200, by=25)){
MM$h = function (x, t, th = c(1.66e-3*(i/100), 1e-4, 0.1))
{
with(as.list(c(x, th)), {
return(c(th[1] * x1 * x2, th[2] * x3, th[3] * x3))
})
}
out = gillespied1(MM,T=300,dt=0.1)
MM1 <- out[,1]
MM2 = out[,2]
MM3 = out[,3]
MM4 = out[,4]
for (j in 1:40) {
out = gillespied1(MM, T=300, dt=0.1)
MM1 = cbind(MM1,out[,1])
MM2 = cbind(MM2,out[,2])
MM3 = cbind(MM3,out[,3])
MM4 = cbind(MM4,out[,4])
}
a =matrix(rowMeans(MM1))
b = matrix(rowMeans(MM2))
c = matrix(rowMeans(MM3))
d = matrix(rowMeans(MM4))
if (q = 1) {
lines(a, lwd="1.5", col =cl[2*((i/25)-1)-1])
} else if ( q=2) {
lines(b, lwd="1.5", col =cl[2*((i/25)-1)-1])
} else if ( q=3) {
lines(c, lwd="1.5", col =cl[2*((i/25)-1)-1])
} else
lines(d, lwd="1.5", col =cl[2*((i/25)-1)-1])
}
axis(side = 1, at = (0:300)*10 , labels = 0:300)
legend("topright", legend=c("50%","75%","100%","125%","150%","175%", "200%"), lty =c(rep(1)), lwd=c(rep(1)), title ="% of original substrate rate parameter", col=cl[seq(1,13,2)], cex=0.4)
}
I keep getting this error
Error: unexpected '}' in "}"
but I can't tell why.
If my code was working perfectly I should end up with 4 graphs, each graph containing 7 lines.
Any help would be amazing. Thanks.
From the link:
Relational Operators
Description
Binary operators which allow the comparison of values in atomic vectors.
Usage
x == y
I was trying to execute this functions, but I kept on getting an error with my if statment: Error in if (value[1][i] < 0) { : missing value where TRUE/FALSE needed:
Monte_Carlo <- function(trial)
{
S_T <- S_o*exp((r - q - (1/2)*sigma^2)*period + sigma*rnorm(trial, mean = 0, sd = 1))
K <- matrix(100, nrow = 1, ncol = 20)
value <- K - S_T
for(i in 1:trial)
{
if(value[1][i] < 0)
{
value[1][i] = 0;
}
}
return (mean(value)*exp(-r))
}
You are indexing your matrix incorrectly. value[1] will return a single value, which you are then trying to assign the ith element of, for i up to trial
If you assign to the ith element in the 1st row (which looks as if you are trying to do), then it will work
Monte_Carlo <- function(trial)
{
S_T <- S_o*exp((r - q - (1/2)*sigma^2)*period + sigma*rnorm(trial, mean = 0, sd = 1))
K <- matrix(100, nrow = 1, ncol = 20)
value <- K - S_T
for(i in 1:trial)
{
if(value[1, i] < 0)
{
value[1,i] = 0;
}
}
return (mean(value)*exp(-r))
}
you can remove the for loop and if statement with pmax which is vectorized and will return elementwise the maximum of value and 0.
Monte_Carlo <- function(trial)
{
S_T <- S_o*exp((r - q - (1/2)*sigma^2)*period + sigma*rnorm(trial, mean = 0, sd = 1))
K <- matrix(100, nrow = 1, ncol = trial)
value <- K - S_T
.value <- pmax(value,0)
return (mean(.value)*exp(-r)
}
As a matter of good programming, I would add r,S_o, q, sigma and period as arguments to your function, so that it doesn't depend on global variables