I'm having a problem with implementing the function bt.matching.find from the SIT toolbox which is hosted on Github. After downloading the toolbox following the steps described here, I tried to replicate the code described in this blog
library(SIT.dates)
library(SIT)
objt <- bt.matching.find(Cl(data), normalize.fn = normalize.mean, dist.fn = 'dist.euclidean', plot=T)
R did not find the function, so I tried using spacing to access the function
objt <- SIT:::bt.matching.find(Cl(data), normalize.fn = normalize.mean, dist.fn = 'dist.euclidean', plot=T)
But this time I got a weird error which has nothing to do with any argument in the function
Error in last(data, n.reference) : could not find function "last"
I did research on the function bt.matching.find using the function getAnywhere and here's what I got
getAnywhere("bt.matching.find")
A single object matching ‘bt.matching.find’ was found
It was found in the following places
namespace:SIT
with value
function (data, n.query = 90, n.reference = 252 * 10, n.match = 10,
normalize.fn = normalize.mean.sd, dist.fn = dist.euclidean,
plot = FALSE, plot.dist = FALSE, layout = NULL, main = NULL)
{
data = last(data, n.reference)
reference = coredata(data)
n = len(reference)
query = reference[(n - n.query + 1):n]
reference = reference[1:(n - n.query)]
main = paste(main, join(format(range(index(data)[(n - n.query +
1):n]), "%d%b%Y"), " - "))
n.query = len(query)
n.reference = len(reference)
dist.fn.name = ""
if (is.character(dist.fn)) {
dist.fn.name = paste("with", dist.fn)
dist.fn = get(dist.fn)
}
dist = rep(NA, n.reference)
query.normalized = match.fun(normalize.fn)(query)
for (i in n.query:n.reference) {
window = reference[(i - n.query + 1):i]
window.normalized = match.fun(normalize.fn)(window)
dist[i] = match.fun(dist.fn)(rbind(query.normalized,
window.normalized))
if (i%%100 == 0)
cat(i, "\n")
}
min.index = c()
temp = dist
temp[temp > mean(dist, na.rm = T)] = NA
for (i in 1:n.match) {
if (any(!is.na(temp))) {
index = which.min(temp)
min.index[i] = index
temp[max(0, index - 2 * n.query):min(n.reference,
(index + n.query))] = NA
}
}
n.match = len(min.index)
if (plot) {
dates = index(data)[1:len(dist)]
if (is.null(layout)) {
if (plot.dist)
layout(1:2)
else layout(1)
}
par(mar = c(2, 4, 2, 2))
if (plot.dist) {
plot(dates, dist, type = "l", col = "gray", main = paste("Top
Historical Matches for",
main, dist.fn.name), ylab = "Distance", xlab = "")
abline(h = mean(dist, na.rm = T), col = "darkgray",
lwd = 2)
points(dates[min.index], dist[min.index], pch = 22,
col = "red", bg = "red")
text(dates[min.index], dist[min.index], 1:n.match,
adj = c(1, 1), col = "black", xpd = TRUE)
}
plota(data, type = "l", col = "gray", LeftMargin = 1,
main = iif(!plot.dist, paste("Top Historical Matches for",
main), NULL))
plota.lines(last(data, 90), col = "blue")
for (i in 1:n.match) {
plota.lines(data[(min.index[i] - n.query + 1):min.index[i]],
col = "red")
}
text(index4xts(data)[min.index - n.query/2], reference[min.index -
n.query/2], 1:n.match, adj = c(1, -1), col = "black",
xpd = TRUE)
plota.legend(paste("Pattern: ", main, ",Match Number"),
"blue,red")
}
return(list(min.index = min.index, dist = dist[min.index],
query = query, reference = reference, dates = index(data),
main = main))
}
<bytecode: 0x000000e7e11c8a00>
<environment: namespace:SIT>
I tried calling the function using backports package
library(backports)
.onLoad <- function(libname, pkgname) {
backports::import(SIT, "bt.matching.find", force = TRUE)
}
But this also didn't work
Why is R not able to access the function? could this be because this package was built under an older version?
Additional information
Environment
sessionInfo()
R version 3.5.3 (2019-03-11)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 8.1 x64 (build 9600)
The problem was solved with help from the developer of the package, for anyone who is interested in using the code, here are the adjustments that should be done
library(SIT)
library(quantmod)
tickers = 'SPY'
data = getSymbols(tickers, src = 'yahoo', from = '1950-01-01', auto.assign = F)
obj = SIT:::bt.matching.find(Cl(data), normalize.fn = SIT:::normalize.mean, dist.fn = 'dist.euclidean', plot=T)
matches = SIT:::bt.matching.overlay(obj, plot.index=1:90, plot=T)
layout(1:2)
matches = SIT:::bt.matching.overlay(obj, plot=T, layout=T)
SIT:::bt.matching.overlay.table(obj, matches, plot=T, layout=T)
Related
I have a data:
df_1 <- data.frame(
x = c("AA", "BB"),
y = c(1, 2)
)
and the following function:
lessR::PieChart(
hole = 0,
x = x, y = y, data = df_1,
values_digits = 1,
values_color = "#020202",
values_size = 1,
color = "black",
lwd = 1.5,
fill = c("orange", "steelblue"),
main = "Percent"
)
The error occurs:
Error in if (theme != getOption("theme")) { : argument is of length zero
I can't use the library or a withr (or similar) functions, as I'm using the golem framework, which doesn't allow loading packages even temporarily.
I am trying to run this code for wgcna to relate modules * traits:
weight <- as.data.frame(datTraits[, "weight", drop = FALSE])
names(weight) = "weight"
modNames = substring(names(MEs), 3)
geneModuleMembership = as.data.frame(cor(datExpr, MEs, use = "p"));
MMPvalue = as.data.frame(corPvalueStudent(as.matrix(geneModuleMembership), nSamples));
names(geneModuleMembership) = paste("MM", modNames, sep="");
names(MMPvalue) = paste("p.MM", modNames, sep="");
geneTraitSignificance = as.data.frame(cor(datExpr, weight, use = "p"));
GSPvalue = as.data.frame(corPvalueStudent(as.matrix(geneTraitSignificance), nSamples));
names(geneTraitSignificance) = paste("GS.", names(weight), sep="");
names(GSPvalue) = paste("p.GS.", names(weight), sep="");
##Plotting the graph
module = "plum1"
column = match(module, modNames);
moduleGenes = moduleColors==module;
pdf("plum1.pdf", width = 7, height = 7);
par(mfrow = c(1,1));
verboseScatterplot(abs(geneModuleMembership[moduleGenes, column]),
abs(geneTraitSignificance[moduleGenes, 1]),
xlab = paste("Module Membership in", module, "module"),
ylab = "Gene significance",
main = paste("Module membership vs. gene significance\n"),
cex.main = 1.2, cex.lab = 1.2, cex.axis = 1.2, col = module)
It runs without any error but does not give the scatter plot output. Thank you!
I am using the referenceIntervals package in R, to do some data analytics.
In particular I am using the refLimit function which calculates reference and confidence intervals. I want to edit it to remove certain functionality (for instance it runs a shapiro normalitiy test, which stops the entire code if the data larger than 5000, it wont allow you to parametrically test samples less than 120). To do this I have been typing refLimit into the terminal - copying the function definition, then saving it as a separate file (below is the full original definition of the function).
singleRefLimit =
function (data, dname = "default", out.method = "horn", out.rm = FALSE,
RI = "p", CI = "p", refConf = 0.95, limitConf = 0.9)
{
if (out.method == "dixon") {
output = dixon.outliers(data)
}
else if (out.method == "cook") {
output = cook.outliers(data)
}
else if (out.method == "vanderLoo") {
output = vanderLoo.outliers(data)
}
else {
output = horn.outliers(data)
}
if (out.rm == TRUE) {
data = output$subset
}
outliers = output$outliers
n = length(data)
mean = mean(data, na.rm = TRUE)
sd = sd(data, na.rm = TRUE)
norm = NULL
if (RI == "n") {
methodRI = "Reference Interval calculated nonparametrically"
data = sort(data)
holder = nonparRI(data, indices = 1:length(data), refConf)
lowerRefLimit = holder[1]
upperRefLimit = holder[2]
if (CI == "p") {
CI = "n"
}
}
if (RI == "r") {
methodRI = "Reference Interval calculated using Robust algorithm"
holder = robust(data, 1:length(data), refConf)
lowerRefLimit = holder[1]
upperRefLimit = holder[2]
CI = "boot"
}
if (RI == "p") {
methodRI = "Reference Interval calculated parametrically"
methodCI = "Confidence Intervals calculated parametrically"
refZ = qnorm(1 - ((1 - refConf)/2))
limitZ = qnorm(1 - ((1 - limitConf)/2))
lowerRefLimit = mean - refZ * sd
upperRefLimit = mean + refZ * sd
se = sqrt(((sd^2)/n) + (((refZ^2) * (sd^2))/(2 * n)))
lowerRefLowLimit = lowerRefLimit - limitZ * se
lowerRefUpperLimit = lowerRefLimit + limitZ * se
upperRefLowLimit = upperRefLimit - limitZ * se
upperRefUpperLimit = upperRefLimit + limitZ * se
shap_normalcy = shapiro.test(data)
shap_output = paste(c("Shapiro-Wilk: W = ", format(shap_normalcy$statistic,
digits = 6), ", p-value = ", format(shap_normalcy$p.value,
digits = 6)), collapse = "")
ks_normalcy = suppressWarnings(ks.test(data, "pnorm",
m = mean, sd = sd))
ks_output = paste(c("Kolmorgorov-Smirnov: D = ", format(ks_normalcy$statistic,
digits = 6), ", p-value = ", format(ks_normalcy$p.value,
digits = 6)), collapse = "")
if (shap_normalcy$p.value < 0.05 | ks_normalcy$p.value <
0.05) {
norm = list(shap_output, ks_output)
}
else {
norm = list(shap_output, ks_output)
}
}
if (CI == "n") {
if (n < 120) {
cat("\nSample size too small for non-parametric confidence intervals, \n \t\tbootstrapping instead\n")
CI = "boot"
}
else {
methodCI = "Confidence Intervals calculated nonparametrically"
ranks = nonparRanks[which(nonparRanks$SampleSize ==
n), ]
lowerRefLowLimit = data[ranks$Lower]
lowerRefUpperLimit = data[ranks$Upper]
upperRefLowLimit = data[(n + 1) - ranks$Upper]
upperRefUpperLimit = data[(n + 1) - ranks$Lower]
}
}
if (CI == "boot" & (RI == "n" | RI == "r")) {
methodCI = "Confidence Intervals calculated by bootstrapping, R = 5000"
if (RI == "n") {
bootresult = boot::boot(data = data, statistic = nonparRI,
refConf = refConf, R = 5000)
}
if (RI == "r") {
bootresult = boot::boot(data = data, statistic = robust,
refConf = refConf, R = 5000)
}
bootresultlower = boot::boot.ci(bootresult, conf = limitConf,
type = "basic", index = 1)
bootresultupper = boot::boot.ci(bootresult, conf = limitConf,
type = "basic", index = 2)
lowerRefLowLimit = bootresultlower$basic[4]
lowerRefUpperLimit = bootresultlower$basic[5]
upperRefLowLimit = bootresultupper$basic[4]
upperRefUpperLimit = bootresultupper$basic[5]
}
RVAL = list(size = n, dname = dname, out.method = out.method,
out.rm = out.rm, outliers = outliers, methodRI = methodRI,
methodCI = methodCI, norm = norm, refConf = refConf,
limitConf = limitConf, Ref_Int = c(lowerRefLimit = lowerRefLimit,
upperRefLimit = upperRefLimit), Conf_Int = c(lowerRefLowLimit = lowerRefLowLimit,
lowerRefUpperLimit = lowerRefUpperLimit, upperRefLowLimit = upperRefLowLimit,
upperRefUpperLimit = upperRefUpperLimit))
class(RVAL) = "interval"
return(RVAL)
}
However when I then execute this file a large number of terms end up being undefined, for instance when I use the function I get 'object 'nonparRanks' not found'.
How do I edit the function in the package? I have looked at trying to important the package namespace and environment but this has not helped. I have also tried to find the actual function in the package files in my directory, but not been able to.
I am reasonably experienced in R, but I have never had to edit a package before. I am clearly missing something about how functions are defined in packages, but I am not sure what.
In the beginning of the package there is a line
data(sysdata, envir=environment())
See here: https://github.com/cran/referenceIntervals/tree/master/data/sysdata.rda
I suspect that "nonparRanks" is defined there as I don't see it defined anywhere else. So perhaps you could download that file, write your own function, then run that same line before running your function and it may work.
EDIT:
Download the file then run:
load("C:/sysdata.rda")
With your path to the file and then your function will work.
nonparRanks is a function in the referenceIntervals package:
Table that dictate the ranks for the confidence intervals
around thecalculated reference interval
Your method of saving and editing the function is fine, but make sure you load all the necessary underlying functions to run it too.
The easiest thing to do might be to:
save your copied and pasted R function as a different name, e.g. singleRefLimit2, then
call library("referenceIntervals"), which will load all the underlying functions you need and then
load your function source("singelRefLimit2.R"), with whatever edits you choose to make.
I am using biwavelet package to conduct wavelet analysis. However, when I want to adjust the label size for axis using cex.axis, the label size does not changed. On the other hand, cex.lab and cex.main are working well. Is this a bug? The following gives a reproducible example.
library(biwavelet)
t1 <- cbind(1:100, rnorm(100))
t2 <- cbind(1:100, rnorm(100))
# Continuous wavelet transform
wt.t1 <- wt(t1)
par(oma = c(0, 0.5, 0, 0), mar = c(4, 2, 2, 4))
plot(wt.t1,plot.cb = T,plot.phase = T,type = 'power.norm',
xlab = 'Time(year)',ylab = 'Period(year)',mgp=c(2,1,0),
main='Winter station 1',cex.main=0.8,cex.lab=0.8,cex.axis=0.8)
Edit
There was a previous question on this site a month ago: Wavelets plot: changing x-, y- axis, and color plot, but not solved. Any help this time? Thank you!
Yeah, it is a bug. Here is patched version: my.plot.biwavelet()
This version accepts argument cex.axis (defaults to 1), and you can change it when needed. I will briefly explain to you what the problem is, in the "explanation" section in the end.
my.plot.biwavelet <- function (x, ncol = 64, fill.cols = NULL, xlab = "Time", ylab = "Period",
tol = 1, plot.cb = FALSE, plot.phase = FALSE, type = "power.corr.norm",
plot.coi = TRUE, lwd.coi = 1, col.coi = "white", lty.coi = 1,
alpha.coi = 0.5, plot.sig = TRUE, lwd.sig = 4, col.sig = "black",
lty.sig = 1, bw = FALSE, legend.loc = NULL, legend.horiz = FALSE,
arrow.len = min(par()$pin[2]/30, par()$pin[1]/40), arrow.lwd = arrow.len *
0.3, arrow.cutoff = 0.9, arrow.col = "black", xlim = NULL,
ylim = NULL, zlim = NULL, xaxt = "s", yaxt = "s", form = "%Y", cex.axis = 1,
...) {
if (is.null(fill.cols)) {
if (bw) {
fill.cols <- c("black", "white")
}
else {
fill.cols <- c("#00007F", "blue", "#007FFF",
"cyan", "#7FFF7F", "yellow", "#FF7F00", "red",
"#7F0000")
}
}
col.pal <- colorRampPalette(fill.cols)
fill.colors <- col.pal(ncol)
types <- c("power.corr.norm", "power.corr", "power.norm",
"power", "wavelet", "phase")
type <- match.arg(tolower(type), types)
if (type == "power.corr" | type == "power.corr.norm") {
if (x$type == "wtc" | x$type == "xwt") {
x$power <- x$power.corr
x$wave <- x$wave.corr
}
else {
x$power <- x$power.corr
}
}
if (type == "power.norm" | type == "power.corr.norm") {
if (x$type == "xwt") {
zvals <- log2(x$power)/(x$d1.sigma * x$d2.sigma)
if (is.null(zlim)) {
zlim <- range(c(-1, 1) * max(zvals))
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- 2^locs
}
else if (x$type == "wtc" | x$type == "pwtc") {
zvals <- x$rsq
zvals[!is.finite(zvals)] <- NA
if (is.null(zlim)) {
zlim <- range(zvals, na.rm = TRUE)
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- locs
}
else {
zvals <- log2(abs(x$power/x$sigma2))
if (is.null(zlim)) {
zlim <- range(c(-1, 1) * max(zvals))
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- 2^locs
}
}
else if (type == "power" | type == "power.corr") {
zvals <- log2(x$power)
if (is.null(zlim)) {
zlim <- range(c(-1, 1) * max(zvals))
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- 2^locs
}
else if (type == "wavelet") {
zvals <- (Re(x$wave))
if (is.null(zlim)) {
zlim <- range(zvals)
}
locs <- pretty(range(zlim), n = 5)
leg.lab <- locs
}
else if (type == "phase") {
zvals <- x$phase
if (is.null(zlim)) {
zlim <- c(-pi, pi)
}
locs <- pretty(range(zlim), n = 5)
leg.lab <- locs
}
if (is.null(xlim)) {
xlim <- range(x$t)
}
yvals <- log2(x$period)
if (is.null(ylim)) {
ylim <- range(yvals)
}
else {
ylim <- log2(ylim)
}
image(x$t, yvals, t(zvals), zlim = zlim, xlim = xlim,
ylim = rev(ylim), xlab = xlab, ylab = ylab, yaxt = "n",
xaxt = "n", col = fill.colors, ...)
box()
if (class(x$xaxis)[1] == "Date" | class(x$xaxis)[1] ==
"POSIXct") {
if (xaxt != "n") {
xlocs <- pretty(x$t) + 1
axis(side = 1, at = xlocs, labels = format(x$xaxis[xlocs],
form))
}
}
else {
if (xaxt != "n") {
xlocs <- axTicks(1)
axis(side = 1, at = xlocs, cex.axis = cex.axis)
}
}
if (yaxt != "n") {
axis.locs <- axTicks(2)
yticklab <- format(2^axis.locs, dig = 1)
axis(2, at = axis.locs, labels = yticklab, cex.axis = cex.axis)
}
if (plot.coi) {
polygon(x = c(x$t, rev(x$t)), lty = lty.coi, lwd = lwd.coi,
y = c(log2(x$coi), rep(max(log2(x$coi), na.rm = TRUE),
length(x$coi))), col = adjustcolor(col.coi,
alpha.f = alpha.coi), border = col.coi)
}
if (plot.sig & length(x$signif) > 1) {
if (x$type %in% c("wt", "xwt")) {
contour(x$t, yvals, t(x$signif), level = tol,
col = col.sig, lwd = lwd.sig, add = TRUE, drawlabels = FALSE)
}
else {
tmp <- x$rsq/x$signif
contour(x$t, yvals, t(tmp), level = tol, col = col.sig,
lwd = lwd.sig, add = TRUE, drawlabels = FALSE)
}
}
if (plot.phase) {
a <- x$phase
locs.phases <- which(zvals < quantile(zvals, arrow.cutoff))
a[locs.phases] <- NA
phase.plot(x$t, log2(x$period), a, arrow.len = arrow.len,
arrow.lwd = arrow.lwd, arrow.col = arrow.col)
}
box()
if (plot.cb) {
fields::image.plot(x$t, yvals, t(zvals), zlim = zlim, ylim = rev(range(yvals)),
xlab = xlab, ylab = ylab, col = fill.colors,
smallplot = legend.loc, horizontal = legend.horiz,
legend.only = TRUE, axis.args = list(at = locs,
labels = format(leg.lab, dig = 2)), xpd = NA)
}
}
Test
library(biwavelet)
t1 <- cbind(1:100, rnorm(100))
t2 <- cbind(1:100, rnorm(100))
# Continuous wavelet transform
wt.t1 <- wt(t1)
par(oma = c(0, 0.5, 0, 0), mar = c(4, 2, 2, 4))
my.plot.biwavelet(wt.t1,plot.cb = T,plot.phase = T,type = 'power.norm',
xlab = 'Time(year)',ylab = 'Period(year)',mgp=c(2,1,0),
main='Winter station 1',cex.main=0.8,cex.lab=0.8,cex.axis=0.8)
As expected, it is working.
Explanation
In plot.biwavelet(), why passing cex.axis via ... does not work?
plot.biwavelet() generates the your final plot mainly in 3 stages:
image(..., xaxt = "n", yaxt = "n") for generating basic plot;
axis(1, at = atTicks(1)); axis(2, at = atTicks(2)) for adding axis;
fields::image.plot() for displaying colour legend strip.
Now, although this function takes ..., they are only fed to the first image() call, while the following axis(), (including polygon(), contour(), phase.plot()) and image.plot() take none from .... When later calling axis(), no flexible specification with respect to axis control are supported.
I guess during package development time, problem described as in: Giving arguments from “…” argument to right function in R had been encountered. Maybe the author did not realize this potential issue, leaving a bug here. My answer to that post, as well as Roland's comments, points toward a robust fix.
I am not the package author so can not decide how he will fix this. My fix is brutal, but works for you temporary need: just add the cex.axis argument to axis() call. I have reached Tarik (package author) with an email, and I believe he will give you a much better explanation and solution.
I fixed this issue by passing the ... argument to axis in plot.biwavelet. Your code should now work as desired. Note that changes to cex.axis and other axis arguments will affect all three axes (x, y, z).
You can download the new version (0.20.8) of biwavelet from GitHub by issuing the following command at the R console (this assumes that you have the package devtools already installed): devtools::install_github("tgouhier/biwavelet")
Thanks for pointing out the bug!
How might one add labels to an archmap from the archetypes package? Or alternatively, would it be possible to recreate the archmap output in ggplot?
Using code from the SportsAnalytics demo (I hope this isn't bad form)
library("SportsAnalytics")
library("archetypes")
data("NBAPlayerStatistics0910")
dat <- subset(NBAPlayerStatistics0910,
select = c(Team, Name, Position,
TotalMinutesPlayed, FieldGoalsMade))
mat <- as.matrix(subset(dat, select = c(TotalMinutesPlayed, FieldGoalsMade)))
a3 <- archetypes(mat, 3)
archmap(a3)
I'd like the player names ( NBAPlayerStatistics0910$Name ) over the points on the chart. Something like below but more readable.
If you don't mind tweaking things a bit, you can start with the archmap() function base, toss in an extra parameter and add a text() call:
amap2 <- function (object, a.names, projection = simplex_projection, projection_args = list(),
rotate = 0, cex = 1.5, col = 1, pch = 1, xlab = "", ylab = "",
axes = FALSE, asp = TRUE, ...)
{
stopifnot("archetypes" %in% class(object))
stopifnot(is.function(projection))
k <- object$k
if (k < 3) {
stop("Need at least 3 archetypes.\n")
}
cmds <- do.call(projection, c(list(parameters(object)), projection_args))
if (rotate != 0) {
a <- pi * rotate/180
A <- matrix(c(cos(a), -sin(a), sin(a), cos(a)), ncol = 2)
cmds <- cmds %*% A
}
hmds <- chull(cmds)
active <- 1:k %in% hmds
plot(cmds, type = "n", xlab = xlab, ylab = ylab, axes = axes,
asp = asp, ...)
points(coef(object) %*% cmds, col = col, pch = pch)
######################
# PLAY WITH THIS BIT #
######################
text(coef(object) %*% cmds, a.names, pos=4)
######################
rad <- ceiling(log10(k)) + 1.5
polygon(cmds[hmds, ])
points(cmds[active, ], pch = 21, cex = rad * cex, bg = "grey")
text(cmds[active, ], labels = (1:k)[active], cex = cex)
if (any(!active)) {
points(cmds[!active, , drop = FALSE], pch = 21, cex = rad *
cex, bg = "white", fg = "grey")
text(cmds[!active, , drop = FALSE], labels = (1:k)[!active],
cex = cex, col = "grey20")
}
invisible(cmds)
}
amap2(a3, dat$Name)
Obviously, my completely quick stab is not the end result you're looking for, but it should help you get on your way (if I read what you want to do correctly).