I am using the following code to check P-values of a linear trend, but it seems that the loop is not working properly as I cannot see a 2-D map of P-value but only a row
library(chron)
library(RColorBrewer)
library(lattice)
library(ncdf4)
#-------------------------------------------------------------------------------------------
options(warn=-1)
ncin <- nc_open("MOD04_10K_Winter.nc", readunlim=FALSE)
#print(ncin)
lon <- ncvar_get(ncin, varid="Longitude", start=NA, count=NA, verbose=FALSE,
signedbyte=TRUE, collapse_degen=TRUE, raw_datavals=FALSE )
lat <- ncvar_get(ncin, varid="Latitude", start=NA, count=NA, verbose=FALSE,
signedbyte=TRUE, collapse_degen=TRUE, raw_datavals=FALSE )
aod <- ncvar_get(ncin, varid="AOD", start=NA, count=NA, verbose=FALSE,
signedbyte=TRUE, collapse_degen=TRUE, raw_datavals=FALSE )
px <- matrix(nrow = 1:length(lon), ncol = 1:length(lat))
is.matrix(px)
for (lo in 1:length(lon)) {
for (la in 1:length(lat)) {
int1a = aod[lo, la,]
# if mean of int is finite then proceed else fill NA to all arrays
mn = mean(int1a, trim = 0, na.rm = FALSE)
if (is.finite(mn))
{
print("---------------- Reading Finite data -------------")
xs = 1:30
fn1a = lm(int1a~xs) # Function_NCP
p_val = summary(fn1a)$coefficients[2, 4] # Saving p-value
if (p_val < 0.05) {print("statisticlly significant")} else {print("statisticlly in-significant")}
print(p_val)
print(lo)
print(la)
px[lo][la] = p_val # variables in [] only (?)
}
} # latitude dimension
}
If I am using [lo, la] instead of [lo][la] I am having the following error
Error in [<-(*tmp*, lo, la, value = 0.0543481042240582) :
subscript out of bounds
Sorry if the solution is very trivial, I have just started working in R.
You have just to make a small fix on the matrix px declaration. Now you set the number of rows and columns as vectors: nrow = 1:length(lon) and nrow = 1:length(lon). R silently takes only the first elements of these vectors and generates a 1 to 1 matrix. (Actually, it would generate a warning, by the warnings are supressed!)
So, the solution is
px <- matrix(nrow = length(lon), ncol = length(lat))
Related
I have a dataframe that has two columns, x and y (both populated with numbers). I am trying to look at a moving window within the data, and I've done it like this (source):
# Extract just x and y from the original data frame
df <- dat_fin %>% select(x, y)
# Moving window creation
nr <- nrow(df)
windowSize <- 10
windfs <- lapply(seq_len(nr - windowSize + 1), function(i) df[i:(i + windowSize - 1), ])
This lapply creates a list of tibbles that are each 10 (x, y) pairs. At this point, I am trying to compute a single quantity using each of the sets of 10 pairs; my current (not working) code looks like this:
library(shotGroups)
for (f in 1:length(windfs)) {
tsceps[f] = getCEP(windfs[f], accuracy = TRUE)
}
When I run this, I get the error:
Error in getCEP.default(windfs, accuracy = TRUE) : xy must be numeric
My goal is that the variable that I've called tsceps should be a 1 x length(windfs) data frame, each value in which comes from the getCEP calculation for each of the windowed subsets.
I've tried various things with unnest and unlist, all of which were unsuccessful.
What am I missing?
Working code:
df <- dat_fin %>% select(x, y)
nr <- nrow(df)
windowSize <- 10
windfs <- lapply(seq_len(nr - windowSize + 1), function(i) df[i:(i + windowSize - 1), ])
tsceps <- vector(mode = "numeric", length = length(windfs))
library(shotGroups)
for (j in 1:length(windfs)) {
tsceps[j] <- getCEP(windfs[[j]], type = "CorrNormal", CEPlevel = 0.50, accuracy = TRUE)
}
ults <- unlist(tsceps)
ults_cep <- vector(mode = "numeric", length = length(ults))
for (k in 1:length(ults)) {
ults_cep[k] <- ults[[k]]
}
To get this working with multiple type arguments to getCEP, just use additional code blocks for each type required.
I have a data set from a sample without replacement look like this:
The picture shows the frequency of each species, and there are 50 data.c[[k]] like this.
Now I'm trying the Jackknife resampling(without replacement) to estimate coverage, codes below:
data.c <- sapply(1:50, function(k)table(data[,k])) #freq
mdata <- sapply(1:50, function(k)sum(data.c[[k]]==1))
True_c <- 1- sum(np*(exp(lchoose(N-data.c[[k]], i))/exp(lchoose(N,i))))
##True_c function shows error message##
my result shows "Error in N - data.c : non-numeric argument to binary operator"
I want to do True_c with N(population size) minus species' frequncies and do the 'lchoose' function, how can I do or adjust my codes?
My entire codes show below:
### without replacement
for (seed in c(99,100)){
set.seed(seed)
for (s in c(100,1000)){
sdata <- rlnorm(s,0,1)
p <- sdata/sum(sdata)
gn <- p*s*10
gn <- round(gn)
M <-replace(gn, gn==0,1) #or M=gn[gn==0]=1
N <- sum(M); N
np <- M/N #new prob
pop_index = rep(1:s, time=M)
for (i in c(100,500,1000,5000,N))
{
data=replicate(50, sample(pop_index, i,
replace = FALSE, prob = NULL))
data.c=sapply(1:50, function(k)table(data[,k])) #freq
mdata=sapply(1:50, function(k)sum(data.c[[k]]==1)) #each group, total freq=1
True_c <- 1- sum(np*(exp(lchoose(N-data.c, i))/exp(lchoose(N,i))))
c.hat <- (1-(1-(i/N))*(mdata/i)) #geo
bias=mean(c.hat)-True_c
var=var(c.hat)
cat("sample_size",i,"\n",
"True_C=",True_c,"\n",
"bias =",bias,"\n",
"variance=",var,"\n","\n")
}
}
}
I would like to get non-NA values extracted from random coordinates of a raster within each grid cell.
An example of a raster
library(raster)
r <- raster(ncol = 10, nrow = 10, xmx = -80, xmn = -150, ymn = 20, ymx = 60)
values(r) <- runif(ncell(r))
An example of a grid
grid <- raster(extent(r))
res(grid) <- 15
proj4string(grid)<- proj4string(r)
gridpolygon <- rasterToPolygons(grid)
plot(r)
plot(gridpolygon, add = T)
How can I extract a value with random coordinates for each raster portions inside each grid cells?
I am really new at this kind of stuff so any suggestions will be very welcome.
Thanks.
You didn't specify all the condition for sampling, so I'm going by some assumptions here.
One can sample a point per grid polygon and extract the value. Here's how you can do it in one go and hope for the best:
# pick random points per each grid cell and plot
set.seed(357)
pickpts <- sapply(gridpolygon#polygons, spsample, n = 1, type = "random")
sapply(pickpts, plot, add = TRUE)
# extract values of raster cells at specified points
sapply(pickpts, FUN = extract, x = r)
Or you can do it in a loop and sample until you get a non-NA value.
N <- length(gridpolygon#polygons)
result <- rep(NA, times = N)
for (i in 1:N) {
message(sprintf("Trying polygon %d", i))
pl <- gridpolygon#polygons[[i]]
candval <- result[i] # start with NA
# sample until you get a non-NA hit
while (is.na(candval)) {
pickpoint <- spsample(pl, n = 1, type = "random")
candval <- extract(x = r, y = pickpoint)
}
result[i] <- candval
}
result
[1] 0.4235214 0.6081435 0.9126583 0.1710365 0.7788590 0.9413206 0.8589753
[8] 0.0376722 0.9662231 0.1421353 0.0804440 0.1969363 0.1519467 0.1398272
[15] 0.4783207
I am trying to compute prediction intervals for my neural network created with the neuralnet package.
I use R in Tableau Software, by creating .RData files containing my functions and loaded in Tableau.
It's a simple NN, with one hidden layer containing 5 nodes. I searched and found this package : nnetpredint
So I tried to use it, using their examples.
I tried also to change the way I use it (train/test in same data frame, separated data frames with the same columns names etc.)
And the best result I had was the prediction, but without the lowerBound and upperBound columns.
In fact, I got exactly the same result as when I use compute(myNN, etc.), but I don't have the second and third columns.
Thanks for your help,
EDIT :
My data is coming from tableau, my function take five parameters which are :
ValuesToExplain,train1,train2,test1,test2.
Then, i create and train my NN with the 3first and try to compute the two last.
(test1 = k*train1 and test2 = k2*train2 for now but it will probably move in the future).
Here is my whole code :
NNetwork <- function(objectiveValues, knownValues1, knownValues2, newData, newData2){
numberOfColumn = 3
##Create the training dataframe
training <- data.frame(objectiveValues, knownValues1,knownValues2)
training[which(is.na(training[,"objectiveValues"])),"objectiveValues"]<- mean(training[,"objectiveValues"], na.rm = TRUE)
training[which(is.na(training[,"knownValues1"])),"knownValues1"]<- mean(training[,"knownValues1"], na.rm = TRUE)
training[which(is.na(training[,"knownValues2"])),"knownValues2"]<- mean(training[,"knownValues2"], na.rm = TRUE)
## Create the testing dataframe
testing <- data.frame(objectiveValues,newData,newData2)
names(testing) <- c("objectiveValues", "knownValues1", "knownValues2")
testing[which(is.na(testing[,"objectiveValues"])),"objectiveValues"]<- mean(testing[,"objectiveValues"], na.rm = TRUE)
testing[which(is.na(testing[,"knownValues1"])),"knownValues1"]<- mean(testing[,"knownValues1"], na.rm = TRUE)
testing[which(is.na(testing[,"knownValues2"])),"knownValues2"]<- mean(testing[,"knownValues2"], na.rm = TRUE)
## Scaling
maxs <- apply(training, 2, max)
mins <- apply(training, 2, min)
trainingScaled <- as.data.frame(scale(training, center = mins, scale = maxs - mins))
testingScaled <- as.data.frame(scale(testing, center = mins, scale = maxs - mins))
### NeuralNetwork Part
library(neuralnet)
n <- names(trainingScaled)
f <- as.formula(paste("objectiveValues ~", paste(n[!n %in% "objectiveValues"], collapse = " + ")))
# Training NN
nn <- neuralnet(f, data=trainingScaled,hidden=5,linear.output=TRUE)
# Using NN
computedTrainingScaled <- compute(nn,trainingScaled[,2:numberOfColumn])
computedFromNNScaled <- compute(nn,testingScaled[,2:numberOfColumn])
# UnScaling
computedTraining <- computedTrainingScaled$net.result*(max(training$objectiveValues)-min(training$objectiveValues))+min(training$objectiveValues)
computedFromNN <- computedFromNNScaled$net.result*(max(training$objectiveValues)-min(training$objectiveValues))+min(training$objectiveValues)
RSquare = (1-( (sum((training$objectiveValues - computedTraining)^2))/(sum((training$objectiveValues - mean(training$objectiveValues))^2)) ))*100
RSE = sum((training$objectiveValues - computedTraining)^2)/nrow(training)
res <- (1:nrow(training))
library(nnetpredint) # Getting prediction confidence interval
x <- trainingScaled[,2:numberOfColumn]
y <- trainingScaled[1]
newData <- testingScaled[,2:numberOfColumn]
# S3 generic method: Object of nn
yPredInt <- nnetPredInt(nn, x, y, newData)
for(i in 1:nrow(training)){
res[i] <- paste(computedFromNN[i],RSquare,RSE, sep="#")
}
return(res)
}
save(NNetwork, file = "NNetwork.RData")
Here, i removed the part using the nnetpredint pckage because it was not working, but it was like this :
library(nnetpredint)
y <- trainingScaled
x <- trainingScaled[,2:3]
newData <- testingScaled[,2:3]
yPredInt <- nnetPredInt(nn, x, y, newData)
My problem is that when I try to access yPredInt$lowerBound or yPredInt$upperBound , they don't exist.
I'm quite new to R and I have a problem on which I couldn't find a solution so far.
I have a folder of 1000 raster files. I have to get the median of all rasters for each cell.
The files contain NoData Cells (I think therefore they have different extents)
Is there any solution to loop through the folder, adding together all files an getting the median?
Error in rep(value, times = ncell(x)) : invalid 'times' argument
In addition: Warning message:
In setValues(x, rep(value, times = ncell(x))) : NAs introduced by coercion
Error in .local(x, i, j, ..., value) :
cannot replace values on this raster (it is too large
I tried with raster stack, but it doesn't work because of the different extents.
Thanks for your help.
I'll try to approach this by mosaic()'ing images with different extents and origins but same resolution.
Create a few rasterLayer objects and export them (to read latter)
library('raster')
library('rgdal')
e1 <- extent(0,10,0,10)
r1 <- raster(e1)
res(r1) <- 0.5
r1[] <- runif(400, min = 0, max = 1)
#plot(r1)
e2 <- extent(5,15,5,15)
r2 <- raster(e2)
res(r2) <- 0.5
r2[] <- rnorm(400, 5, 1)
#plot(r2)
e3 <- extent(18,40,18,40)
r3 <- raster(e3)
res(r3) <- 0.5
r3[] <- rnorm(1936, 12, 1)
#plot(r3)
# Write them out
wdata <- '../Stackoverflow/21876858' # your local folder
writeRaster(r1, file.path(wdata, 'r1.tif'),
overwrite = TRUE)
writeRaster(r2,file.path(wdata, 'r2.tif'),
overwrite = TRUE)
writeRaster(r3,file.path(wdata, 'r3.tif'),
overwrite = TRUE)
Read and Mosaic'ing with function
Since raster::mosaic do not accept rasterStack/rasterBrick or lists of rasterLayers, the best approach is to use do.call, like this excellent example.
To do so, adjust mosaic signature and how to call its arguments with:
setMethod('mosaic', signature(x='list', y='missing'),
function(x, y, fun, tolerance=0.05, filename=""){
stopifnot(missing(y))
args <- x
if (!missing(fun)) args$fun <- fun
if (!missing(tolerance)) args$tolerance<- tolerance
if (!missing(filename)) args$filename<- filename
do.call(mosaic, args)
})
Let's keep tolerance low here to evaluate any misbehavior of our function.
Finally, the function:
Mosaic function
f.Mosaic <- function(x=x, func = median){
files <- list.files(file.path(wdata), all.files = F)
# List TIF files at wdata folder
ltif <- grep(".tif$", files, ignore.case = TRUE, value = TRUE)
#lext <- list()
#1rt <- raster(file.path(wdata, i),
# package = "raster", varname = fname, dataType = 'FLT4S')
# Give an extent area here (you can read it from your first tif or define manually)
uext <- extent(c(0, 100, 0, 100))
# Get Total Extent Area
stkl <- list()
for(i in 1:length(ltif)){
x <- raster(file.path(wdata, ltif[i]),
package = "raster", varname = fname, dataType = 'FLT4S')
xext <- extent(x)
uext <- union(uext, xext)
stkl[[i]] <- x
}
# Global Area empty rasterLayer
rt <- raster(uext)
res(rt) <- 0.5
rt[] <- NA
# Merge each rasterLayer to Global Extent area
stck <- list()
for(i in 1:length(stkl)){
merged.r <- merge(stkl[[i]], rt, tolerance = 1e+6)
#merged.r <- reclassify(merged.r, matrix(c(NA, 0), nrow = 1))
stck[[i]] <- merged.r
}
# Mosaic with Median
mosaic.r <- raster::mosaic(stck, fun = func) # using median
mosaic.r
}
# Run the function with func = median
mosaiced <- f.Mosaic(x, func = median)
# Plot it
plot(mosaiced)
Possibly far from the best approach but hope it helps.