R Setter method in class - r

When I write a setter method in a class, the setter method does not change the value. I just cannot find the error here.
point <- function(x,y){
structure(class = "point", list(
# attributes
x = x,
y = y,
# methods
get_x = function() paste("(", x,",",y,")"),
set_x = function(x,y){ self.x = x; self.y = y}
))}
> p <- point(0,1)
> p$get_x()
[1] "( 0 , 1 )"
> p$set_x(6,5)
> p$get_x()
[1] "( 0 , 1 )"


Try to follow this change to your code.
In function set_x, it is the values of variables x and y created in function point that are assigned new values with <<-, not the x and y that exist in the .GlobalEnv.
point <- function(x, y){
structure(class = "point", list(
x = x,
y = y,
get_x = function() paste("(", x,",",y,")"),
set_x = function(x, y){
x <<- x
y <<- y
}
))
}
x <- 0
y <- 1
p <- point(0,1)
p$get_x()
#[1] "( 0 , 1 )"
p$set_x(6,5)
p$get_x()
#[1] "( 6 , 5 )"
x
#[1] 0
y
#[1] 1

Related

parSapplyLB with missing arguments

Suppose fun is a function with 3 arguments (x, y, z) and y or z needs to be specified, but not both.
fun <- function(x, y, z) {
if (missing(y)) {
x^2
} else {
x^5
}
}
Now assume this function gets call within another function as:
fun.v1 <- function(x, y, z) {
sapply(x, fun, y, z)
}
> fun.v1(1:5, y = 4)
[1] 1 32 243 1024 3125
> fun.v1(1:5, z = 4)
[1] 1 4 9 16 25
Rather than using sapply, now I want to implement a parallel backend:
require(parallel)
fun.v2 <- function(x, y, z) {
cl <- makeCluster(2)
bf <- parSapplyLB(cl = cl, X = x, fun, y, z)
stopCluster(cl = cl)
}
fun.v2(1:5, y = 4)
fun.v2(1:5, z = 4)
This code gives an error. Is there a way to fix this?
Update: Below code works as intended. But is there a neater way of doing this?
fun <- function(x, y, z) {
if (is.null(y)) {
x^2
} else {
x^5
}
}
fun.v2 <- function(x, y, z) {
cl <- makeCluster(2)
tmp1 <- if(missing(y))
NULL
else y
tmp2 <- if(missing(z))
NULL
else z
bf <- parSapplyLB(cl = cl, X = x, fun, y = tmp1, z = tmp2)
stopCluster(cl = cl)
return(bf)
}
> fun.v2(1:5, y = 4)
[1] 1 32 243 1024 3125
> fun.v2(1:5, z = 4)
[1] 1 4 9 16 25

It seems that y and z are both non-optional arguments. You can make them optional as follows:
fun.v2 <- function(x, y = NULL, z = NULL) {
cl <- makeCluster(2)
bf <- parSapplyLB(cl = cl, X = x, fun, y, z)
stopCluster(cl = cl)
}
This no longer throws an error.

R-caret-plyr : how to modify downSample function to create sampled data of different proportions

Below is the downSample function of caret that I found here .
downSample <- function(x, y, list = FALSE, yname = "Class")
{
xc <- class(x)
if(!is.data.frame(x)) x <- as.data.frame(x)
if(!is.factor(y))
{
warning("Down-sampling requires a factor variable as the response. The original data was returned.")
return(list(x = x, y = y))
}
minClass <- min(table(y))
x$.outcome <- y
x <- ddply(x, .(y),
function(dat, n) dat[sample(seq(along = dat$.outcome), n),,drop = FALSE],
n = minClass)
y <- x$.outcome
x <- x[, !(colnames(x) %in% c("y", ".outcome")), drop = FALSE]
if(list)
{
if(xc[1] == "matrix") x <- as.matrix(x)
out <- list(x = x, y = y)
} else {
out <- cbind(x, y)
colnames(out)[ncol(out)] <- yname
}
out
}
suppose that my data set is iris :
data(iris)
x <- iris[, -5]
y <- iris[, 5]
to make the response variable a hugely unbalanced binary one :
y[-c(130, 146)] <- "setosa"
There are now therefore two instances of "virginica" and 148 instances of "setosa". I would like to modify the function downSample so that, in the end, instead of returning a subsampled data set with 50% of minClass, it returns a subsampled data set with for instance 30% (k) of minor class and 70% of major class. Because using the downSample function for n instances in the minClass it selects n instances of the other class to get a fully balanced data set. But in my case I loose a lot of data so I just want to balance it a bit not fully.
Let's suppose that k = 20 % i.e. in the end I want 20% of minClaas and 80% of the other class. I have already tried to modify this part of function :
x <- ddply(x, .(y), function(dat, n)
dat[sample(seq(along = dat$.outcome), n),, drop = FALSE], n = minClass)
by changing n to 4*n but I did not achieve it. There is this error :
Error in size <= n/2 :
comparison (4) is possible only for atomic and list types
Your help would be appreciated.

A simple way to perform this is to change the n = minClass part of the ddply call.
downSample_custom <- function(x, y, list = FALSE, yname = "Class", frac = 1){ #add argument frac which is in the 0 - 1 range
xc <- class(x)
if(!is.data.frame(x)) x <- as.data.frame(x)
if(!is.factor(y))
{
warning("Down-sampling requires a factor variable as the response. The original data was returned.")
return(list(x = x, y = y))
}
minClass <- min(table(y))
x$.outcome <- y
x <- ddply(x, .(y),
function(dat, n) dat[sample(seq(along = dat$.outcome), n),,drop = FALSE],
n = minClass*frac) #change the n to this
y <- x$.outcome
x <- x[, !(colnames(x) %in% c("y", ".outcome")), drop = FALSE]
if(list)
{
if(xc[1] == "matrix") x <- as.matrix(x)
out <- list(x = x, y = y)
} else {
out <- cbind(x, y)
colnames(out)[ncol(out)] <- yname
}
out
}
Does it work:
library(plyr)
imbalanced y:
set.seed(1)
y <- as.factor(sample(c("M", "F"),
prob = c(0.1, 0.9),
size = 10000,
replace = TRUE))
x <- rnorm(10000)
table(downSample_custom(x, y)[,2])
output:
F M
1044 1044
table(downSample_custom(x, y, frac = 0.5)[,2])
output:
F M
522 522
table(downSample_custom(x, y, frac = 0.2)[,2])
output
F M
208 208
using frac > 1 returns an error:
downSample_custom(x, y, frac = 2)
output
Error in sample.int(length(x), size, replace, prob) :
cannot take a sample larger than the population when 'replace = FALSE'
EDIT: answer to the updated question.
This can be achieved for instance by sampling the indexes of each class separately. Here is an example that works only for two class problems:
downSample_custom <- function(x, y, yname = "Class", frac = 1){
lev <- levels(y)
minClass <- min(table(y))
lev_min <- levels(y)[which.min(table(y))]
inds_down <- sample(which(y == lev[lev != lev_min]), size = minClass * frac) #sample the indexes of the more abundant class according to minClass * frac
inds_minClass <- which(y == lev[lev == lev_min]) #take all the indexes of the lesser abundant class
out <- data.frame(x, y)
out <- out[sort(c(inds_down, inds_minClass)),]
colnames(out)[ncol(out)] <- yname
return(out)
}
how it looks in practice:
table(downSample_custom(x, y)[,2])
output:
F M
1044 1044
table(downSample_custom(x, y, frac = 5)[,2])
output:
F M
5220 1044
head(downSample_custom(x, y, frac = 5))
output:
x Class
1 -1.5163733 F
2 0.6291412 F
4 1.1797811 M
5 1.1176545 F
6 -1.2377359 F
7 -1.2301645 M

Function accumulated

a <- function(x){
a = 2*x*x
return(a)
}
b (x) <- a(1) + a(2) + ... + a(x)
there is function a, I want to write a function b,which is a accumulation of function a.
I write it in R.

Maybe like this:
a <- function(x)
{2*x*x}
b<- function(y)
{sum(sapply(seq(y),a))}
so
b(3) = 28
since
b(3) = a(1) + a(2) + a(3)
= 2*1*1 + 2*2*2 + 2*3*3
= 2 + 8 + 18
= 28

Function b creates an expression and evaluates that expression to return the result.
a <- function(x){
return(2*x*x)
}
b <- function(x){
eval( parse( text = paste0( strsplit( paste0( "a(", x, ")"), " "), collapse = "+") ))
}
b(1:2)
# [1] 10
b(1:3)
# [1] 28
b(1:5)
# [1] 110
b(c(2,4,6))
# [1] 112

Multiple FOR loop flow chart

I am beginner in R and trying to understand multiple FOR loop. I was expecting output will be {6,12} but getting {3,12}.
x=6(1+2+3)
xx <- function() {
x <- c(0)
y <- c(0)
z <- c(0)
for (i in 1:3) {
x <- x + 1
for (k in 1:4) {
y <- y + 1
}
y
}
z <- c(x, y)
}

You are wrong because if you use x + 1 you will get in step_1 = 0 + 1, step_2 = 1 + 1 = 2, and in step_3 = 2 + 1 = 3, print this last value. Now if you want to get the output (6,12), it would be as follows:
x <- y <- z <- c(0)
for (i in 1:3) {
x <- x + i
for (k in 1:4) {
y <- y + 1
}
}
z <- c(x, y)
print(z)

Error - this S4 class is not subsettable

I know there are several answers on this question, however I could not find any applicable to my question. Could anyone help me in regards to the error this S4 class is not subsettable at the bottom of this code. I am not sure where this error comes from. The output result should be the thresholded coefficients of DWT.
xx <- list(list(c(1,2,3,4,5,6,7,5,4,3,2,4,3,2,3,5,4,3,2,3,4,5,6,3,4,3,3),
c(0,3,1,4,1,2,7,5,4,1,3,4,9,2,7,5,1,3,2,2,1,1,1,5,1,3,1)),
list(c(0,3,1,4,1,2,7,5,4,1,3,4,9,2,2,4,7,6,4,2,1,1,1,5,1,3,1),
c(1,2,3,4,5,6,7,5,4,3,5,4,3,2,3,4,5,6,3,2,1,2,3,5,4,3,3)),
list(c(0,3,1,4,1,2,7,5,4,1,3,4,3,2,2,4,7,6,4,2,1,1,1,5,1,3,1),
c(1,2,3,4,5,6,4,3,2,3,5,4,3,2,3,4,5,6,3,2,1,2,3,5,4,3,3)))
# Select Filter.
library(wavelets)
filter <- c ("d2","d4","d6", "c6","d8","la8","la10","d12","c12","la12","la14","d14","d16","la16","d18","c18","la18")
boundary <- c("periodic","reflection")
g <- seq(1:length(xx))
fun <- function (x) seq(1: as.integer (floor (logb ((length(xx[[x]][[1]])),base=2))))
nlevel <- lapply( g,fun)
fun <- function(x) expand.grid(filter=filter,nlevel=nlevel[[x]],boundary=boundary, stringsAsFactors=FALSE)
w3<- lapply(g,fun)
z <- c(seq(1:length(w3)))
mapply3 <- function(i) {
w4 <- w3[[i]]
mapply ( function ( m,k,p,x ) modwt ( x, filter = m, n.levels = k, boundary=p) , w3[[i]]$filter, w3[[i]]$nlevel, w3[[i]]$boundary , MoreArgs = list(x = (xx[[i]][[1]])) )
}
DWT <- lapply ( z, mapply3 )
#---------------------------------------------------------------------------
vscale <- c("level")
# smooth.levels <- c(nlevel)
prior <- c("laplace")
a <- c(0.1,0.3)
bayesfac <- c("TRUE")
threshrule <- c("median","mean")
#---------------------------------------------------------------------------
X <- seq(1:length(DWT))
fun <- function (x) DWT[x]
u <- lapply(X,fun)
fun <- function (x) seq(1:length(DWT[[x]]))
U <- lapply(X,fun)
L1 <- expand.grid ( vscale = vscale, prior = prior, a = a , bayesfac = bayesfac , threshrule = threshrule , stringsAsFactors = FALSE )
# --------------------------------------------------------------------------
library ( EbayesThresh )
mapply2 <- function ( DWTi , LL ) {
mapply ( function ( c,e,f,g,h,x ) ebayesthresh.wavelet ( x, vscale = c, prior = e, a = f, bayesfac = g, threshrule = h ) , LL$vscale , LL$prior , LL$a , LL$bayesfac , LL$threshrule , MoreArgs = list ( x = DWTi ) )
}
mapply3 <- function( i, L1, DWT ) {
DWTi <- DWT [[i]][U[[i]]]
w3 <- L1
lapply( DWTi, mapply2, w3 )
}
M1 <- lapply(z, mapply3, L1, DWT)
# Error in x.dwt[[j]] : this S4 class is not subsettable

This might be a bug in the "wavelets" package. I looked up the source code of ebayesthresh.wavelet, copied it, and added some "print" debugging:
#------------------------------------------------------------------------
# The same as "ebayesthresh.wavelet.dwt" plus some "print" for debugging:
ebayesthresh.wvlt.dwt <-
function (x.dwt, vscale = "independent", smooth.levels = Inf,
prior = "laplace", a = 0.5, bayesfac = FALSE, threshrule = "median")
{
nlevs <- length(x.dwt) - 1
slevs <- min(nlevs, smooth.levels)
print("nlevs:")
print(nlevs)
print("slevs")
print(slevs)
if (is.character(vscale)) {
vs <- substring(vscale, 1, 1)
if (vs == "i")
vscale <- mad(x.dwt[[1]])
if (vs == "l")
vscale <- NA
}
print("1:slevs:")
print(1:slevs)
for (j in 1:slevs) {
print("j:")
print(j)
x.dwt[[j]] <- ebayesthresh(x.dwt[[j]], prior, a, bayesfac,
vscale, FALSE, threshrule)
print("OK")
}
return(x.dwt)
}
#----------------------------------------------------------------------------
# The same as "ebayesthresh.wavelet",
# but it calls "ebayesthresh.wvlt.dwt" instead of "ebayesthresh.wavelet.dwt":
ebayesthresh.wvlt <-
function (xtr, vscale = "independent", smooth.levels = Inf, prior = "laplace",
a = 0.5, bayesfac = FALSE, threshrule = "median")
{
xcl <<- class(xtr)
if (class(xcl) == "dwt " && length(xcl) > 1) {
xtr <- ebayesthresh.wavelet.splus(xtr, vscale, smooth.levels,
prior, a, bayesfac, threshrule)
return(xtr)
}
if (xcl == "wd") {
xtr <- ebayesthresh.wavelet.wd(xtr, vscale, smooth.levels,
prior, a, bayesfac, threshrule)
return(xtr)
}
if (xcl == "dwt" || xcl == "modwt") {
xtr <- ebayesthresh.wvlt.dwt(xtr, vscale, smooth.levels,
prior, a, bayesfac, threshrule)
return(xtr)
}
print("Unknown wavelet transform type; no smoothing performed")
return(xtr)
}
The function mapply2 now calls ebayesthresh.wvlt instead of ebayesthresh.wavelet:
mapply2 <- function ( DWTi , LL )
{
mapply ( function ( c,e,f,g,h,x ) ebayesthresh.wvlt ( x,
vscale = c,
prior = e,
a = f,
bayesfac = g,
threshrule = h ) ,
LL$vscale ,
LL$prior ,
LL$a ,
LL$bayesfac ,
LL$threshrule,
list(x=DWTi ) )
}
Let's see:
> M1 <- lapply(z, mapply3, L1, DWT)
[1] "nlevs:"
[1] 0
[1] "slevs"
[1] 0
[1] "1:slevs:"
[1] 1 0
[1] "j:"
[1] 1
Error in x.dwt[[j]] : this S4 class is not subsettable
>
In R the for-loop
for (j in 1:n) {...}
is not empty, if n is 0 or negative. (Another reason to avoid for-loops?) j runs from 1 to n in steps of -1. A similar bug I found here.
If we replace the for-loop in ebayesthresh.wvlt.dwt by a while-loop, the error message disappears:
j <- 1
while (j<=slevs) {
x.dwt[[j]] <- ebayesthresh(x.dwt[[j]], prior, a, bayesfac,
vscale, FALSE, threshrule)
j <- j+1
}

Resources