Problem
There is 1 main station (df) and 3 local stations (s) stacked in a single data.frame with values for three days. The idea is to take each day from the main station, find the relative anomaly of the three local stations, and smooth it using inverse distance weighting (IDW) from the phylin package. This is then applied to the value in the main station by multiplication.
Any suggestions on improving this code (e.g. data.table, dplyr, apply)? I still don't know how to approach this problem without the cumbersome for loop.
dput
s <- structure(list(id = c("USC00031152", "USC00034638", "USC00036352",
"USC00031152", "USC00034638", "USC00036352", "USC00031152", "USC00034638",
"USC00036352"), lat = c(33.59, 34.7392, 35.2833, 33.59, 34.7392,
35.2833, 33.59, 34.7392, 35.2833), long = c(-92.8236, -90.7664,
-93.1, -92.8236, -90.7664, -93.1, -92.8236, -90.7664, -93.1),
year = c(1900, 1900, 1900, 1900, 1900, 1900, 1900, 1900,
1900), month = c(1, 1, 1, 1, 1, 1, 1, 1, 1), day = c(1L,
1L, 1L, 2L, 2L, 2L, 3L, 3L, 3L), value = c(63.3157576809045,
86.0490598902219, 76.506386949066, 71.3760752788486, 89.9119576975542,
76.3535163951321, 53.7259645981243, 61.7989638892985, 85.8911224149051
)), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA,
-9L), .Names = c("id", "lat", "long", "year", "month", "day",
"value"))
df <- structure(list(id = c(12345, 12345, 12345), lat = c(100, 100,
100), long = c(50, 50, 50), year = c(1900, 1900, 1900), month = c(1,
1, 1), day = 1:3, value = c(54.8780020601509, 106.966029162171,
98.3198828955801)), row.names = c(NA, -3L), class = "data.frame", .Names = c("id",
"lat", "long", "year", "month", "day", "value"))
Code
library(phylin)
nearest <- function(i, loc){
# Stack 3 local stations
stack <- s[loc:(loc+2),]
# Get 1 main station
station <- df[i,]
# Check for NA and build relative anomaly (r)
stack <- stack[!is.na(stack$value),]
stack$r <- stack$value/station$value
# Use IDW and return v
v <- as.numeric(ifelse(dim(stack)[1] == 1,
stack$r,
idw(stack$r, stack[,c(2,3,8)], station[,2:3])))
return(v)
}
ncdc <- 1
for (i in 1:nrow(df)){
# Get relative anomaly from function
r <- nearest(i, ncdc)
# Get value from main station and apply anomaly
p <- df[i,7]
df[i,7] <- p*r
# Iterate to next 3 local stations
ncdc <- ncdc + 3
}
Suppose you let your nearest function unchanged.
Then you could get your new value column in df by
newvalue <- sapply(1:NROW(df), function (i) df[i,7] * nearest(i, 3*(i-1)+1))
df$value <- newvalue
Related
I have a dataset with all natural disaster that occured over a certain time period. I would like to summarize them by year and state. When summarizing I would like to create a variable (= d_disasters) that shows me the unique types of natural disasters, e.g. for Texas, I would expect to only show Hurricane.
I am currently using dplyr:group_by and dplyr::summarize to summarize my data by year and by state & dplyr::mutate and dplyr:map_int to create new variables with the total number of natural disasters per year ($n_disasters using length) and the unique number of natural disasters ($n_distinct using n_distinct()).
Starting dataset:
structure(list(year = c(1998, 1998, 1998, 1998, 1998), country = c("US",
"US", "US", "US", "US"), state = c("Texas", "Texas", "California",
"New York", "New York"), deaths = c(12, 5, 9, 10, 18), injured = c(3,
1, 3, 5, 9), disastertype = c("Hurricane", "Hurricane", "Wild fire",
"Flood", "Epidemic")), class = "data.frame", row.names = c(NA,
-5L))
Result dataset:
structure(list(year = c(1998, 1998, 1998), state = c("California",
"New York", "Texas"), u_disastertype = c("Wild fire", "Flood, Epidemic",
"Hurricane"), disastertype = c("Wild fire", "Flood, Epidemic",
"Hurricane, Hurricane"), deaths = c(9, 28, 17), injured = c(3,
14, 4), n_distinct = c(1L, 2L, 1L), n_disasters = c(1L, 2L, 2L
)), class = c("grouped_df", "tbl_df", "tbl", "data.frame"), row.names = c(NA,
-3L), groups = structure(list(year = 1998, .rows = structure(list(
1:3), ptype = integer(0), class = c("vctrs_list_of", "vctrs_vctr",
"list"))), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA,
-1L), .drop = TRUE))
EDIT: Edited for clarification.
Try aggregate. This takes the output of 2 3 aggregates and puts them together.
list2 <- function(x){ c(unique(x),length(table(x))) }
lt <- list(year=dat$year, county=dat$country, state=dat$state )
data.frame( aggregate( dat[,c(4,5)], lt, sum ),
setNames( aggregate( dat$disastertype, lt, list2 )[,4, drop=F], colnames(dat)[6] ),
setNames( aggregate( dat$disastertype, lt, length )[,4, drop=F], "n_disasters") )
year county state deaths injured disastertype n_disasters
1 1998 US California 9 3 Wild fire, 1 1
2 1998 US New York 28 14 Flood, Epidemic, 2 2
3 1998 US Texas 17 4 Hurricane, 1 2
Not sure if you want to keep the n_... columns or not though...
EDIT: added "n_disasters"
EDIT2: added suggestion to include "distinct disasters"
The solution using dplyr with group_by and summarize. The key part is to run u_disastertype = toString(unique(disastertype)), before disastertype = paste(disastertype, collapse = ', '),
naturaldisaster2 <- naturaldisaster %>%
group_by(year, state) %>%
summarise(
u_disastertype = toString(unique(disastertype)),
disastertype = paste(disastertype, collapse = ', '),
deaths=sum(deaths),
injured=sum(injured)
)
The answer is based on this Stackoverflow answer to a similar question, where only one operation was run on the column whereas I am running two operations on the same column: https://stackoverflow.com/a/46367425/11045110
Let's say I have a parameter V which is equal to 100 on row v. I have another parameter D on row d that is equal to 100 too. I would like to create a dataframe with N rows above row v and M rows below row d, so that v-Nth row is equal to V + Nf and d+Mth row is equal to D - Mf. For this example, let's assume that f is equal to 5:
Input:
> dput(df)
structure(list(rw = structure(2:1, .Label = c("d", "v"), class = "factor"),
vals = c(100, 100)), class = "data.frame", row.names = c(NA,
-2L))
Expected output:
> dput(df)
structure(list(rw = structure(c(8L, 7L, 6L, 5L, 1L, 2L, 3L, 4L
), .Label = c("d", "d+1", "d+2", "d+M", "v", "v-1", "v-2", "v-N"
), class = "factor"), vals = c(85, 90, 95, 100, 100, 105, 110,
115)), class = "data.frame", row.names = c(NA, -8L))
How can I achieve this? Let me know if you have any questions.
Thanks!
We can use Map with seq to create a sequence of values by looping over the rows of 'vals' column, then pass another variable byval with sign for getting the sequence backwards or forwards for each corresponding element of 'vals' and pass it on the by argument in seq while setting the constant length of sequence to output as 4 ('n'). Then, set the names of the list wiith the 'rw' column and convert the list to a two column data.frame with stack
byval <- 5
n <- 4
stack(setNames(Map(function(x, y) sort(seq(x, length.out = n, by = y)),
df$vals, c(-byval, byval)), df$rw))[2:1]
If we need different length.out, pass it as another parameter
n1 <- 6
n2 <- 5
stack(setNames(Map(function(x, y, z) sort(seq(x, length.out = z, by = y)),
df$vals, c(-byval, byval), c(n1, n2)), df$rw))[2:1]
Let's say I have a data which involves 3 separate data. Here is my data;
data<-structure(list(x = structure(list(value = c(2L, 4L, 5L, 6L, 9L,
4L, 3L, 2L, 10L, 6L)), .Names = "value", class = "data.frame", row.names = c(NA,
-10L)), y = structure(list(value = c(2, 2.1, 4, 3, 0, 1.2, 4.2,
3, 4, 9)), .Names = "value", class = "data.frame", row.names = c(NA,
-10L)), z = structure(list(value = c(1, 2, 7, 6, 0.3, 5.4, 4,
3, 6, 7)), .Names = "value", class = "data.frame", row.names = c(NA,
-10L))), .Names = c("x", "y", "z"))
And here is my sample function;
sam<-function(x) {
ex<-c(3,2,4,5,2)
z<-data.frame(x)
y<-as.matrix(sapply(z, as.numeric))
h<-lapply(c(2,5,10), function(xx) tapply(y, as.integer(gl(nrow(x), xx, nrow(x)) ), FUN = sum))
names(h)<-c("min2", "min5", "min10")
min2<-h[[1]]
pdf("plots.pdf")
plot(min2, ex, main="min. compare",
xlab="Historical Values ", ylab="Disaggregated Values", pch=19, col = "blue")
dev.off()
return(h)
}
In the function, I am aggregating values as shown. And then plotting min2 with ex data.
With the code below, I tried to use the function for all data like;
v1<-sapply(data, sam)
But I can not see calculation's name as min2 min5 min10 in result list. And also results are coming complexly, not under the x, y and z
I desire these two;
1) Grouping results under each data name. Like;
[x] [y] [z]
min2 min2 min2
min5 min5 min5
min10 min10 min10
2) Plotting the desired ones for all x, y and z as mentioned above. And export three plots to one pdf or separately.
To get the output, like #JonnyPhelps suggested, use lapply instead of sapply. To make the plots and get correlation you need to alter the function:
sam<-function(x) {
ex<-c(3,2,4,5,2)
z<-data.frame(x)
y<-as.matrix(sapply(z, as.numeric))
h<-lapply(c(2,5,10), function(xx) tapply(y, as.integer(gl(nrow(x), xx, nrow(x)) ), FUN = sum))
names(h)<-c("min2", "min5", "min10")
min2<-h[[1]]
plot(min2, ex, main="min. compare",
xlab="Historical Values ", ylab="Disaggregated Values",
pch=19, col = "blue")
COR = cor.test(min2,ex)
LABEL = paste("cor=",signif(COR$estimate,3),"\np=",signif(COR$p.value,3))
mtext(LABEL,side=3,padj=2)
return(h)
}
The correlation is calculated and you use mtext to place it at the top of the plot. You can play around with padj and adj to get the text where you need.
In your previous function, you called the plot in the function, this overwrites the file with every iteration. To plot all on a pdf, you need to do:
pdf("plots.pdf")
v1<-lapply(data, sam)
dev.off()
Or if you want them on the same page:
pdf("plots.pdf",width=8,height=4)
par(mfrow=c(1,3))
v1<-lapply(data, sam)
dev.off()
I am new to R and I do have to calculate the mean of time series, containing 5 years, with hourly taken data of ozon etc..
My df looks like:
structure(list(date = structure(c(1L, 1L, 1L, 1L), .Label = "01.01.2010", class = "factor"),
day.of = c(1L, 1L, 1L, 1L), time = structure(1:4, .Label = c("00:00",
"01:00", "02:00", "03:00"), class = "factor"), SVF_Ray = c(1L,
1L, 1L, 1L), Gmax = c(0, 0, 0, 0), Ta = c(-1.3, -1.2, -1.2,
-1.2), Tmrt = c(-19.3, -12.1, -12, -12.1), PET = c(-10.4,
-8.7, -8.7, -8.7), PT = c(-11.3, -9.3, -9.3, -9.3), Ozon = c(61.35,
62.65, 63.4, 63.85), rDatum = structure(c(14610, 14610, 14610,
14610), class = "Date"), year = c(2010, 2010, 2010, 2010),
month = c(1, 1, 1, 1), day = c(1, 1, 1, 1), hour = c(0, 1,
2, 3)), .Names = c("date", "day.of", "time", "SVF_Ray", "Gmax",
"Ta", "Tmrt", "PET", "PT", "Ozon", "rDatum", "year", "month",
"day", "hour"), row.names = c(NA, 4L), class = "data.frame")
I would like to calculate the mean of Ozon every 8 hours, so a series of 4 calculated means for every day. I have arranged my datum like:
Datum_Ozon$rDatum <- as.Date(data$date, format="%d.%m.%Y")
Datum_Ozon$hour<-as.numeric(unlist(strsplit(as.character(df$time), ":"))[seq(1, 2 * length(df$time), 2)])
Format is numeric
But I don't know any further in achieving my goal. Thanks in advance!
If its the case that your data is regular and complete (ie, every hour has a record), the following base R code should do the trick:
# Get the number of 8 hour intervals
intervalCnt <- nrow(df) / 8L
# add a grouping vector to your data
df$group <- rep(1:intervalCnt, each=8)
# get the median for each interval, keep year var around for later
intervalMedian <- aggregate(var~group + day + month + year, data=df, FUN=median)
Note that this solution relies on the assumption that the data has a regular structure, i.e., every hour has a record. If the measure of interest is missing, i.e. NA, then simply adding na.rm to the aggregate function will return the statistics of interest:
# get the median for each interval
intervalMedian <- aggregate(var~group + day + month + year, data=df, FUN=median, na.rm=T)
If you have a variable for hour of the day, here is a simple way to check for data regularity:
table(df$hourOfDay)
The result of this function is a frequency count of each hour. The counts should be equal. Another thing to check is that the first observation starts in the hour following the final observation, i.e. if the hour of observation 1 == "00:00", then the hour of the final observation should be 23:00.
To provide a plot of the mean of the 8 hour periods by year, you can again use aggregate:
intervalMeans.year <- aggregate(var~group, data=intervalMedian,
FUN=mean, na.rm=T)
The inclusion of the group, day, month, and year variables in the intervalMedian data.frame allow for a lot of different aggregations. For example, with a minor adjustment, it is possible to get the average value of a variable over the 5 year period for each time period-day-month:
intervalMedian$periodDay <- rep(1:3, length.out=intervalMedian)
intervalMeans.dayMonthPeriod <- aggregate(var~periodDay+day+month,
data=intervalMedian, FUN=mean, na.rm=T)
Here is a basic example using a dplyr pipe rather than a plyr approach as well as ifelse(). Everything is self contained here:
library(dplyr)
## OP data
df <-
structure(list(date = structure(c(1L, 1L, 1L, 1L), .Label = "01.01.2010", class = "factor"),
day.of = c(1L, 1L, 1L, 1L), time = structure(1:4, .Label = c("00:00",
"01:00", "02:00", "03:00"), class = "factor"), SVF_Ray = c(1L,
1L, 1L, 1L), Gmax = c(0, 0, 0, 0), Ta = c(-1.3, -1.2, -1.2,
-1.2), Tmrt = c(-19.3, -12.1, -12, -12.1), PET = c(-10.4,
-8.7, -8.7, -8.7), PT = c(-11.3, -9.3, -9.3, -9.3), Ozon = c(61.35,
62.65, 63.4, 63.85), rDatum = structure(c(14610, 14610, 14610,
14610), class = "Date"), year = c(2010, 2010, 2010, 2010),
month = c(1, 1, 1, 1), day = c(1, 1, 1, 1), hour = c(0, 1,
2, 3)), .Names = c("date", "day.of", "time", "SVF_Ray", "Gmax",
"Ta", "Tmrt", "PET", "PT", "Ozon", "rDatum", "year", "month",
"day", "hour"), row.names = c(NA, 4L), class = "data.frame")
df %>%
mutate(DayChunk=ifelse(hour %in% c(0:7),"FirstThird",
ifelse(hour %in% c(8:15), "SecondThird"
,"ThirdThird")
)) %>%
group_by(Date, DayChunk) %>%
summarise(MedOzon=median(Ozon))
Look up the function seq.POSIXt. There are options to specify the start and stop intervals. This function is designed to create sequences of time. For your problem:
myseq<-seq(ISOdate(2010,01,01, 00, 00, 00, tz="GMT"), to=ISOdate(2016,01,05), by = "8 hour")
Use the ISOdate functions to set the start and stop times. If you are going to be working much with times, I suggest researching the function strptime and the POSIXlt/ct time classes.
Now with the breaks defined and assuming you have a column in your dataframe (Datum_Ozon) named "datetime", then use "cut" to group/subset your data.
Datum_Ozon$datetime<-as.POSIXct(paste(as.character(Datum_Ozon$date),
as.character(Datum_Ozon$time)), "%d.%m.%Y %H:%M", tz="GMT" )
library(dplyr)
summarize(group_by(Datum_Ozon, cut(Datum_Ozon$datetime, myseq)), mean(Ozon))
Here is some sample data for which I want to encode the gender of the names over time:
names_to_encode <- structure(list(names = structure(c(2L, 2L, 1L, 1L, 3L, 3L), .Label = c("jane", "john", "madison"), class = "factor"), year = c(1890, 1990, 1890, 1990, 1890, 2012)), .Names = c("names", "year"), row.names = c(NA, -6L), class = "data.frame")
Here is a minimal set of the Social Security data, limited to just those names from 1890 and 1990:
ssa_demo <- structure(list(name = c("jane", "jane", "john", "john", "madison", "madison"), year = c(1890L, 1990L, 1890L, 1990L, 1890L, 1990L), female = c(372, 771, 56, 81, 0, 1407), male = c(0, 8, 8502, 29066, 14, 145)), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, -6L), .Names = c("name", "year", "female", "male"))
I've defined a function which subsets the Social Security data given a year or range of years. In other words, it calculates whether a name was male or female over a given time period by figuring out the proportion of male and female births with that name. Here is the function along with a helper function:
require(plyr)
require(dplyr)
select_ssa <- function(years) {
# If we get only one year (1890) convert it to a range of years (1890-1890)
if (length(years) == 1) years <- c(years, years)
# Calculate the male and female proportions for the given range of years
ssa_select <- ssa_demo %.%
filter(year >= years[1], year <= years[2]) %.%
group_by(name) %.%
summarise(female = sum(female),
male = sum(male)) %.%
mutate(proportion_male = round((male / (male + female)), digits = 4),
proportion_female = round((female / (male + female)), digits = 4)) %.%
mutate(gender = sapply(proportion_female, male_or_female))
return(ssa_select)
}
# Helper function to determine whether a name is male or female in a given year
male_or_female <- function(proportion_female) {
if (proportion_female > 0.5) {
return("female")
} else if(proportion_female == 0.5000) {
return("either")
} else {
return("male")
}
}
Now what I want to do is use plyr, specifically ddply, to subset the data to be encoded by year, and merge each of those pieces with the value returned by the select_ssa function. This is the code I have.
ddply(names_to_encode, .(year), merge, y = select_ssa(year), by.x = "names", by.y = "name", all.x = TRUE)
When calling select_ssa(year), this command works just fine if I hard code a value like 1890 as the argument to the function. But when I try to pass it the current value for year that ddply is working with, I get an error message:
Error in filter_impl(.data, dots(...), environment()) :
(list) object cannot be coerced to type 'integer'
How can I pass the current value of year on to ddply?
I think you're making things too complicated by trying to do a join inside ddply. If I were to use dplyr I would probably do something more like this:
names_to_encode <- structure(list(name = structure(c(2L, 2L, 1L, 1L, 3L, 3L), .Label = c("jane", "john", "madison"), class = "factor"), year = c(1890, 1990, 1890, 1990, 1890, 2012)), .Names = c("name", "year"), row.names = c(NA, -6L), class = "data.frame")
ssa_demo <- structure(list(name = c("jane", "jane", "john", "john", "madison", "madison"), year = c(1890L, 1990L, 1890L, 1990L, 1890L, 1990L), female = c(372, 771, 56, 81, 0, 1407), male = c(0, 8, 8502, 29066, 14, 145)), class = c("tbl_df", "tbl", "data.frame"), row.names = c(NA, -6L), .Names = c("name", "year", "female", "male"))
names_to_encode$name <- as.character(names_to_encode$name)
names_to_encode$year <- as.integer(names_to_encode$year)
tmp <- left_join(ssa_demo,names_to_encode) %.%
group_by(year,name) %.%
summarise(female = sum(female),
male = sum(male)) %.%
mutate(proportion_male = round((male / (male + female)), digits = 4),
proportion_female = round((female / (male + female)), digits = 4)) %.%
mutate(gender = ifelse(proportion_female == 0.5,"either",
ifelse(proportion_female > 0.5,"female","male")))
Note that 0.1.1 is still a little finicky about the types of join columns, so I had to convert them. I think I saw some activity on github that suggested that was either fixed in the dev version, or at least something they're working on.